Theory Category

(*  Title:       Category
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Category"

theory Category
imports Main "HOL-Library.FuncSet"
begin

  text ‹
    This theory develops an ``object-free'' definition of category loosely following
    \cite{AHS}, Sec. 3.52-3.53.
    We define the notion ``category'' in terms of axioms that concern a single
    partial binary operation on a type, some of whose elements are to be regarded
    as the ``arrows'' of the category.

    The nonstandard definition of category has some advantages and disadvantages.
    An advantage is that only one piece of data (the composition operation) is required
    to specify a category, so the use of records is not required to bundle up several
    separate objects.  A related advantage is the fact that functors and natural
    transformations can be defined simply to be functions that satisfy certain axioms,
    rather than more complex composite objects.
    One disadvantage is that the notions of ``object'' and ``identity arrow'' are
    conflated, though this is easy to get used to.  Perhaps a more significant disadvantage
    is that each arrow of a category must carry along the information about its domain
    and codomain. This implies, for example, that the arrows of a category of sets and
    functions cannot be directly identified with functions, but rather only with functions that
    have been equipped with their domain and codomain sets.

    To represent the partiality of the composition operation of a category, we assume that the
    composition for a category has a unique zero element, which we call null›,
    and we consider arrows to be ``composable'' if and only if their composite is non-null.
    Functors and natural transformations are required to map arrows to arrows and be
    ``extensional'' in the sense that they map non-arrows to null.  This is so that
    equality of functors and natural transformations coincides with their extensional equality
    as functions in HOL.
    The fact that we co-opt an element of the arrow type to serve as null› means that
    it is not possible to define a category whose arrows exhaust the elements of a given type.
    This presents a disadvantage in some situations.  For example, we cannot construct a
    discrete category whose arrows are directly identified with the set of \emph{all}
    elements of a given type @{typ 'a}; instead, we must pass to a larger type
    (such as @{typ "'a option"}) so that there is an element available for use as null›.
    The presence of null›, however, is crucial to our being able to define a
    system of introduction and elimination rules that can be applied automatically to establish
    that a given expression denotes an arrow.  Without null›, we would be able to
    define an introduction rule to infer, say, that the composition of composable arrows
    is composable, but not an elimination rule to infer that arrows are composable from
    the fact that their composite is an arrow.  Having the ability to do both is critical
    to the usability of the theory.
›

  section "Partial Magmas"

  text ‹
    A \emph{partial magma} is a partial binary operation C› defined on the set
    of elements at a type @{typ 'a}.  As discussed above,
    we assume the existence of a unique element null› of type @{typ 'a}
    that is a zero for C›, and we use null› to represent ``undefined''.
    We think of the operation C› as an operation of ``composition'', and
    we regard elements f› and g› of type @{typ 'a} as \emph{composable}
    if C g f ≠ null›.
›

  type_synonym 'a comp = "'a  'a  'a"

  locale partial_magma =
  fixes C :: "'a comp" (infixr "" 55)
  assumes ex_un_null: "∃!n. f. n  f = n  f  n = n"
  begin

    definition null :: 'a
    where "null = (THE n. f. n  f = n  f  n = n)"

    lemma null_eqI:
    assumes "f. n  f = n  f  n = n"
    shows "n = null"
      using assms null_def ex_un_null the1_equality [of "λn. f. n  f = n  f  n = n"]
      by auto
    
    lemma comp_null [simp]:
    shows "null  f = null" and "f  null = null"
      using null_def ex_un_null theI' [of "λn. f. n  f = n  f  n = n"]
      by auto

    text ‹
      An \emph{identity} is a self-composable element a› such that composition of
      any other element f› with a› on either the left or the right results in
      f› whenever the composition is defined.
›

    definition ide
    where "ide a  a  a  null 
                   (f. (f  a  null  f  a = f)  (a  f  null  a  f = f))"

    text ‹
      A \emph{domain} of an element f› is an identity a› for which composition of
      f› with a› on the right is defined.
      The notion \emph{codomain} is defined similarly, using composition on the left.
      Note that, although these definitions are completely dual, the choice of terminology
      implies that we will think of composition as being written in traditional order,
      as opposed to diagram order.  It is pretty much essential to do it this way, to maintain
      compatibility with the notation for function application once we start working with
      functors and natural transformations.
›

    definition domains
    where "domains f  {a. ide a  f  a  null}"

    definition codomains
    where "codomains f  {b. ide b  b  f  null}"

    lemma domains_null:
    shows "domains null = {}"
      by (simp add: domains_def)

    lemma codomains_null:
    shows "codomains null = {}"
      by (simp add: codomains_def)

    lemma self_domain_iff_ide:
    shows "a  domains a  ide a"
      using ide_def domains_def by auto

    lemma self_codomain_iff_ide:
    shows "a  codomains a  ide a"
      using ide_def codomains_def by auto

    text ‹
      An element f› is an \emph{arrow} if either it has a domain or it has a codomain.
      In an arbitrary partial magma it is possible for f› to have one but not the other,
      but the category› locale will include assumptions to rule this out.
›

    definition arr
    where "arr f  domains f  {}  codomains f  {}"

    lemma not_arr_null [simp]:
    shows "¬ arr null"
      by (simp add: arr_def domains_null codomains_null)

    text ‹
      Using the notions of domain and codomain, we can define \emph{homs}.
      The predicate @{term "in_hom f a b"} expresses ``@{term f} is an arrow from @{term a}
      to @{term b},'' and the term @{term "hom a b"} denotes the set of all such arrows.
      It is convenient to have both of these, though passing back and forth sometimes involves
      extra work.  We choose @{term "in_hom"} as the more fundamental notion.
›

    definition in_hom     ("«_ : _  _»")
    where "«f : a  b»  a  domains f  b  codomains f"

    abbreviation hom
    where "hom a b  {f. «f : a  b»}"

    lemma arrI:
    assumes "«f : a  b»"
    shows "arr f"
      using assms arr_def in_hom_def by auto

    lemma ide_in_hom [intro]:
    shows "ide a  «a : a  a»"
      using self_domain_iff_ide self_codomain_iff_ide in_hom_def ide_def by fastforce

    text ‹
      Arrows @{term "f"} @{term "g"} for which the composite @{term "g  f"} is defined
      are \emph{sequential}.
›

    abbreviation seq
    where "seq g f  arr (g  f)"

    lemma comp_arr_ide:
    assumes "ide a" and "seq f a"
    shows "f  a = f"
      using assms ide_in_hom ide_def not_arr_null by metis

    lemma comp_ide_arr:
    assumes "ide b" and "seq b f"
    shows "b  f = f"
      using assms ide_in_hom ide_def not_arr_null by metis

    text ‹
      The \emph{domain} of an arrow @{term f} is an element chosen arbitrarily from the
      set of domains of @{term f} and the \emph{codomain} of @{term f} is an element chosen
      arbitrarily from the set of codomains.
›

    definition dom
    where "dom f = (if domains f  {} then (SOME a. a  domains f) else null)"

    definition cod
    where "cod f = (if codomains f  {} then (SOME b. b  codomains f) else null)"

    lemma dom_null [simp]:
    shows "dom null = null"
      by (simp add: dom_def domains_null)

    lemma cod_null [simp]:
    shows "cod null = null"
      by (simp add: cod_def codomains_null)

    lemma dom_in_domains:
    assumes "domains f  {}"
    shows "dom f  domains f"
      using assms dom_def someI [of "λa. a  domains f"] by auto

    lemma cod_in_codomains:
    assumes "codomains f  {}"
    shows "cod f  codomains f"
      using assms cod_def someI [of "λb. b  codomains f"] by auto

  end

  section "Categories"

  text‹
    A \emph{category} is defined to be a partial magma whose composition satisfies an
    extensionality condition, an associativity condition, and the requirement that every
    arrow have both a domain and a codomain.
    The associativity condition involves four ``matching conditions''
    (match_1›, match_2›, match_3›, and match_4›)
    which constrain the domain of definition of the composition, and a fifth condition
    (comp_assoc'›) which states that the results of the two ways of composing
    three elements are equal.  In the presence of the comp_assoc'› axiom
    match_4› can be derived from match_3› and vice versa.
›

  locale category = partial_magma +
  assumes ext: "g  f  null  seq g f"
  and has_domain_iff_has_codomain: "domains f  {}  codomains f  {}"
  and match_1: " seq h g; seq (h  g) f   seq g f"
  and match_2: " seq h (g  f); seq g f   seq h g"
  and match_3: " seq g f; seq h g   seq (h  g) f"
  and comp_assoc': " seq g f; seq h g   (h  g)  f = h  g  f"
  begin

    text‹
      Associativity of composition holds unconditionally.  This was not the case in
      previous, weaker versions of this theory, and I did not notice this for some
      time after updating to the current axioms.  It is obviously an advantage that
      no additional hypotheses have to be verified in order to apply associativity,
      but a disadvantage is that this fact is now ``too readily applicable,''
      so that if it is made a default simplification it tends to get in the way of
      applying other simplifications that we would also like to be able to apply automatically.
      So, it now seems best not to make this fact a default simplification, but rather
      to invoke it explicitly where it is required.
›

    lemma comp_assoc:
    shows "(h  g)  f = h  g  f"
      by (metis comp_assoc' ex_un_null ext match_1 match_2)

    lemma match_4:
    assumes "seq g f" and "seq h g"
    shows "seq h (g  f)"
      using assms match_3 comp_assoc by auto

    lemma domains_comp:
    assumes "seq g f"
    shows "domains (g  f) = domains f"
    proof -
      have "domains (g  f) = {a. ide a  seq (g  f) a}"
        using domains_def ext by auto
      also have "... = {a. ide a  seq f a}"
        using assms ide_def match_1 match_3 by meson
      also have "... = domains f"
        using domains_def ext by auto
      finally show ?thesis by blast
    qed

    lemma codomains_comp:
    assumes "seq g f"
    shows "codomains (g  f) = codomains g"
    proof -
      have "codomains (g  f) = {b. ide b  seq b (g  f)}"
        using codomains_def ext by auto
      also have "... = {b. ide b  seq b g}"
        using assms ide_def match_2 match_4 by meson
      also have "... = codomains g"
        using codomains_def ext by auto
      finally show ?thesis by blast
    qed

    lemma has_domain_iff_arr:
    shows "domains f  {}  arr f"
      by (simp add: arr_def has_domain_iff_has_codomain)

    lemma has_codomain_iff_arr:
    shows "codomains f  {}  arr f"
      using has_domain_iff_arr has_domain_iff_has_codomain by auto

    text‹
      A consequence of the category axioms is that domains and codomains, if they exist,
      are unique.
›

    lemma domain_unique:
    assumes "a  domains f" and "a'  domains f"
    shows "a = a'"
    proof -
      have "ide a  seq f a  ide a'  seq f a'"
        using assms domains_def ext by force
      thus ?thesis
        using match_1 ide_def not_arr_null by metis
    qed

    lemma codomain_unique:
    assumes "b  codomains f" and "b'  codomains f"
    shows "b = b'"
    proof -
      have "ide b  seq b f  ide b'  seq b' f"
        using assms codomains_def ext by force
      thus ?thesis
        using match_2 ide_def not_arr_null by metis
    qed

    lemma domains_simp:
    assumes "arr f"
    shows "domains f = {dom f}"
      using assms dom_in_domains has_domain_iff_arr domain_unique by auto

    lemma codomains_simp:
    assumes "arr f"
    shows "codomains f = {cod f}"
      using assms cod_in_codomains has_codomain_iff_arr codomain_unique by auto

    lemma domains_char:
    shows "domains f = (if arr f then {dom f} else {})"
      using dom_in_domains has_domain_iff_arr domain_unique by auto

    lemma codomains_char:
    shows "codomains f = (if arr f then {cod f} else {})"
      using cod_in_codomains has_codomain_iff_arr codomain_unique by auto

    text‹
      A consequence of the following lemma is that the notion @{term "arr"} is redundant,
      given @{term "in_hom"}, @{term "dom"}, and @{term "cod"}.  However, I have retained it
      because I have not been able to find a set of usefully powerful simplification rules
      expressed only in terms of @{term "in_hom"} that does not result in looping in many
      situations.
›

    lemma arr_iff_in_hom:
    shows "arr f  «f : dom f  cod f»"
      using cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr in_hom_def
      by auto

    lemma in_homI [intro]:
    assumes "arr f" and "dom f = a" and "cod f = b"
    shows "«f : a  b»"
      using assms cod_in_codomains dom_in_domains has_domain_iff_arr has_codomain_iff_arr
            in_hom_def
      by auto

    lemma in_homE [elim]:
    assumes "«f : a  b»"
    and "arr f  dom f = a  cod f = b  T"
    shows "T"
     using assms in_hom_def domains_char codomains_char has_domain_iff_arr
     by (metis empty_iff singleton_iff)

    text‹
      To obtain the ``only if'' direction in the next two results and in similar results later
      for composition and the application of functors and natural transformations,
      is the reason for assuming the existence of @{term null} as a special element of the
      arrow type, as opposed to, say, using option types to represent partiality.
      The presence of @{term null} allows us not only to make the ``upward'' inference that
      the domain of an arrow is again an arrow, but also to make the ``downward'' inference
      that if @{term "dom f"} is an arrow then so is @{term f}.  Similarly, we will be able
      to infer not only that if @{term f} and @{term g} are composable arrows then
      @{term "C g f"} is an arrow, but also that if @{term "C g f"} is an arrow then
      f› and g› are composable arrows.  These inferences allow most necessary
      facts about what terms denote arrows to be deduced automatically from minimal
      assumptions.  Typically all that is required is to assume or establish that certain
      terms denote arrows in particular homs at the point where those terms are first
      introduced, and then similar facts about related terms can be derived automatically.
      Without this feature, nearly every proof would involve many tedious additional steps
      to establish that each of the terms appearing in the proof (including all its subterms)
      in fact denote arrows.
›

    lemma arr_dom_iff_arr:
    shows "arr (dom f)  arr f"
      using dom_def dom_in_domains has_domain_iff_arr self_domain_iff_ide domains_def
      by fastforce

    lemma arr_cod_iff_arr:
    shows "arr (cod f)  arr f"
      using cod_def cod_in_codomains has_codomain_iff_arr self_codomain_iff_ide codomains_def
      by fastforce

    lemma arr_dom [simp]:
    assumes "arr f"
    shows "arr (dom f)"
      using assms arr_dom_iff_arr by simp

    lemma arr_cod [simp]:
    assumes "arr f"
    shows "arr (cod f)"
      using assms arr_cod_iff_arr by simp

    lemma seqI [simp]:
    assumes "arr f" and "arr g" and "dom g = cod f"
    shows "seq g f"
    proof -
      have "ide (cod f)  seq (cod f) f"
        using assms(1) has_codomain_iff_arr codomains_def cod_in_codomains ext by blast
      moreover have "ide (cod f)  seq g (cod f)"
        using assms(2-3) domains_def domains_simp ext by fastforce
      ultimately show ?thesis
        using match_4 ide_def ext by metis
    qed

    text ‹
      This version of seqI› is useful as an introduction rule, but not as useful
      as a simplification, because it requires finding the intermediary term b›.
      Sometimes \emph{auto} is able to do this, but other times it is more expedient
      just to invoke this rule and fill in the missing terms manually, especially
      when dealing with a chain of compositions.
    ›

    lemma seqI' [intro]:
    assumes "«f : a  b»" and "«g : b  c»"
    shows "seq g f"
      using assms by fastforce

    lemma compatible_iff_seq:
    shows "domains g  codomains f  {}  seq g f"
    proof
      show "domains g  codomains f  {}  seq g f"
        using cod_in_codomains dom_in_domains empty_iff has_domain_iff_arr has_codomain_iff_arr
              domain_unique codomain_unique
        by (metis Int_emptyI seqI)
      show "seq g f  domains g  codomains f  {}"
      proof -
        assume gf: "seq g f"
        have 1: "cod f  codomains f"
          using gf has_domain_iff_arr domains_comp cod_in_codomains codomains_simp by blast
        have "ide (cod f)  seq (cod f) f"
          using 1 codomains_def ext by auto
        hence "seq g (cod f)"
          using gf has_domain_iff_arr match_2 domains_null ide_def by metis
        thus ?thesis
          using domains_def 1 codomains_def by auto
      qed
    qed

    text‹
      The following is another example of a crucial ``downward'' rule that would not be possible
      without a reserved @{term null} value.
›

    lemma seqE [elim]:
    assumes "seq g f"
    and "arr f  arr g  dom g = cod f  T"
    shows "T"
      using assms cod_in_codomains compatible_iff_seq has_domain_iff_arr has_codomain_iff_arr
            domains_comp codomains_comp domains_char codomain_unique
      by (metis Int_emptyI singletonD)

    lemma comp_in_homI [intro]:
    assumes "«f : a  b»" and "«g : b  c»"
    shows "«g  f : a  c»"
    proof
      show 1: "seq g f" using assms compatible_iff_seq by blast
      show "dom (g  f) = a"
        using assms 1 domains_comp domains_simp by blast
      show "cod (g  f) = c"
        using assms 1 codomains_comp codomains_simp by blast
    qed

    lemma comp_in_homI' [simp]:
    assumes "arr f" and "arr g" and "dom f = a" and "cod g = c" and "dom g = cod f"
    shows "«g  f : a  c»"
      using assms by auto

    lemma comp_in_homE [elim]:
    assumes "«g  f : a  c»"
    obtains b where "«f : a  b»" and "«g : b  c»"
      using assms in_hom_def domains_comp codomains_comp
      by (metis arrI in_homI seqE)

    text ‹
      The next two rules are useful as simplifications, but they slow down the
      simplifier too much to use them by default.  So it is necessary to guess when
      they are needed and cite them explicitly.  This is usually not too difficult.
    ›

    lemma comp_arr_dom:
    assumes "arr f" and "dom f = a"
    shows "f  a = f"
      using assms dom_in_domains has_domain_iff_arr domains_def ide_def by auto

    lemma comp_cod_arr:
    assumes "arr f" and "cod f = b"
    shows "b  f = f"
      using assms cod_in_codomains has_codomain_iff_arr ide_def codomains_def by auto

    lemma ide_char:
    shows "ide a  arr a  dom a = a  cod a = a"
      using ide_in_hom by auto

    text ‹
      In some contexts, this rule causes the simplifier to loop, but it is too useful
      not to have as a default simplification.  In cases where it is a problem, usually
      a method like \emph{blast} or \emph{force} will succeed if this rule is cited
      explicitly.
    ›

    lemma ideD [simp]:
    assumes "ide a"
    shows "arr a" and "dom a = a" and "cod a = a"
      using assms ide_char by auto

    lemma ide_dom [simp]:
    assumes "arr f"
    shows "ide (dom f)"
      using assms dom_in_domains has_domain_iff_arr domains_def by auto

    lemma ide_cod [simp]:
    assumes "arr f"
    shows "ide (cod f)"
      using assms cod_in_codomains has_codomain_iff_arr codomains_def by auto

    lemma dom_eqI:
    assumes "ide a" and "seq f a"
    shows "dom f = a"
      using assms cod_in_codomains codomain_unique ide_char
      by (metis seqE)

    lemma cod_eqI:
    assumes "ide b" and "seq b f"
    shows "cod f = b"
      using assms dom_in_domains domain_unique ide_char
      by (metis seqE)

    lemma dom_eqI':
    assumes "a  domains f"
    shows "a = dom f"
      using assms dom_in_domains domain_unique by blast

    lemma cod_eqI':
    assumes "a  codomains f"
    shows "a = cod f"
      using assms cod_in_codomains codomain_unique by blast

    lemma ide_char':
    shows "ide a  arr a  (dom a = a  cod a = a)"
      using ide_dom ide_cod ide_char by metis

    lemma dom_dom:
    assumes "arr f"
    shows "dom (dom f) = dom f"
      using assms by simp

    lemma cod_cod:
    assumes "arr f"
    shows "cod (cod f) = cod f"
      using assms by simp

    lemma dom_cod:
    assumes "arr f"
    shows "dom (cod f) = cod f"
      using assms by simp

    lemma cod_dom:
    assumes "arr f"
    shows "cod (dom f) = dom f"
      using assms by simp

    lemma dom_comp [simp]:
    assumes "seq g f"
    shows "dom (g  f) = dom f"
      using assms by (simp add: dom_def domains_comp)

    lemma cod_comp [simp]:
    assumes "seq g f"
    shows "cod (g  f) = cod g"
      using assms by (simp add: cod_def codomains_comp)

    lemma comp_ide_self [simp]:
    assumes "ide a"
    shows "a  a = a"
      using assms comp_arr_ide arrI by auto

    lemma ide_compE [elim]:
    assumes "ide (g  f)"
    and "seq g f  seq f g  g  f = dom f  g  f = cod g  T"
    shows "T"
      using assms dom_comp cod_comp ide_char ide_in_hom
      by (metis seqE seqI)

    text ‹
      The next two results are sometimes useful for performing manipulations at the
      head of a chain of composed arrows.  I have adopted the convention that such
      chains are canonically represented in right-associated form.  This makes it
      easy to perform manipulations at the ``tail'' of a chain, but more difficult
      to perform them at the ``head''.  These results take care of the rote manipulations
      using associativity that are needed to either permute or combine arrows at the
      head of a chain.
›

    lemma comp_permute:
    assumes "f  g = k  l" and "seq f g" and "seq g h"
    shows "f  g  h = k  l  h"
      using assms by (metis comp_assoc)

    lemma comp_reduce:
    assumes "f  g = k" and "seq f g" and "seq g h"
    shows "f  g  h = k  h"
      using assms comp_assoc by auto

    text‹
      Here we define some common configurations of arrows.
      These are defined as abbreviations, because we want all ``diagrammatic'' assumptions
      in a theorem to reduce readily to a conjunction of assertions of the basic forms
      @{term "arr f"}, @{term "dom f = X"}, @{term "cod f = Y"}, and @{term "in_hom f a b"}.
›

    abbreviation endo
    where "endo f  seq f f"
     
    abbreviation antipar
    where "antipar f g  seq g f  seq f g"

    abbreviation span
    where "span f g  arr f  arr g  dom f = dom g"

    abbreviation cospan
    where "cospan f g  arr f  arr g  cod f = cod g"

    abbreviation par
    where "par f g  arr f  arr g  dom f = dom g  cod f = cod g"

  end

end

Theory ConcreteCategory

(*  Title:       ConcreteCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Concrete Categories"

text ‹
  In this section we define a locale concrete_category›, which provides a uniform
  (and more traditional) way to construct a category from specified sets of objects and arrows,
  with specified identity objects and composition of arrows.
  We prove that the identities and arrows of the constructed category are appropriately
  in bijective correspondence with the given sets and that domains, codomains, and composition
  in the constructed category are as expected according to this correspondence.
  In the later theory Functor›, once we have defined functors and isomorphisms of categories,
  we will show a stronger property of this construction: if C› is any category,
  then C› is isomorphic to the concrete category formed from it in the obvious way by taking
  the identities of C› as objects, the set of arrows of C› as arrows, the identities of
  C› as identity objects, and defining composition of arrows using the composition of C›.
  Thus no information about C› is lost by extracting its objects, arrows, identities, and
  composition and rebuilding it as a concrete category.
  We note, however, that we do not assume that the composition function given as parameter
  to the concrete category construction is ``extensional'', so in general it will contain
  incidental information about composition of non-composable arrows, and this information
  is not preserved by the concrete category construction.
›

theory ConcreteCategory
imports Category
begin

  locale concrete_category =
    fixes Obj :: "'o set"
    and Hom :: "'o  'o  'a set"
    and Id :: "'o  'a"
    and Comp :: "'o  'o  'o  'a  'a 'a"
    assumes Id_in_Hom: "A  Obj  Id A  Hom A A"
    and Comp_in_Hom: " A  Obj; B  Obj; C  Obj; f  Hom A B; g  Hom B C 
                          Comp C B A g f  Hom A C"
    and Comp_Hom_Id: " A  Obj; f  Hom A B   Comp B A A f (Id A) = f"
    and Comp_Id_Hom: " B  Obj; f  Hom A B   Comp B B A (Id B) f = f"
    and Comp_assoc: " A  Obj; B  Obj; C  Obj; D  Obj;
                       f  Hom A B; g  Hom B C; h  Hom C D  
                        Comp D C A h (Comp C B A g f) = Comp D B A (Comp D C B h g) f"
  begin

    datatype ('oo, 'aa) arr =
      Null
    | MkArr 'oo 'oo 'aa

    abbreviation MkIde :: "'o  ('o, 'a) arr"
    where "MkIde A  MkArr A A (Id A)"

    fun Dom :: "('o, 'a) arr  'o"
    where "Dom (MkArr A _ _) = A"
        | "Dom _ = undefined"

    fun Cod
    where "Cod (MkArr _ B _) = B"
        | "Cod _ = undefined"

    fun Map
    where "Map (MkArr _ _ F) = F"
        | "Map _ = undefined"

    abbreviation Arr
    where "Arr f  f  Null  Dom f  Obj  Cod f  Obj  Map f  Hom (Dom f) (Cod f)"

    abbreviation Ide
    where "Ide a  a  Null  Dom a  Obj  Cod a = Dom a  Map a = Id (Dom a)"

    (*
     * Here we use COMP in order that uses of this locale can declare themselves as
     * sublocales and then define the abbreviation comp ≡ COMP.
     *)
    definition COMP :: "('o, 'a) arr comp"
    where "COMP g f  if Arr f  Arr g  Dom g = Cod f then
                         MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
                      else
                         Null"

    interpretation partial_magma COMP
      using COMP_def by (unfold_locales, metis)

    lemma null_char:
    shows "null = Null"
    proof -
      let ?P = "λn. f. COMP n f = n  COMP f n = n"
      have "Null = null"
        using COMP_def null_def the1_equality [of ?P]
        by (metis (no_types, lifting))
      thus ?thesis by simp
    qed

    lemma ide_char:
    shows "ide f  Ide f"
    proof
      assume f: "Ide f"
      show "ide f"
      proof -
        have "COMP f f  null"
          using f COMP_def null_char Id_in_Hom by auto
        moreover have "g. (COMP g f  null  COMP g f = g) 
                           (COMP f g  null  COMP f g = g)"
        proof (intro allI conjI)
          fix g
          show "COMP g f  null  COMP g f = g"
            using f COMP_def null_char Comp_Hom_Id Id_in_Hom
            by (cases g, auto)
          show "COMP f g  null  COMP f g = g"
            using f COMP_def null_char Comp_Id_Hom Id_in_Hom
            by (cases g, auto)
        qed
        ultimately show ?thesis
          using ide_def by blast
      qed
      next
      assume f: "ide f"
      have 1: "Arr f  Dom f = Cod f"
        using f ide_def COMP_def null_char by metis
      moreover have "Map f = Id (Dom f)"
      proof -
        let ?g = "MkIde (Dom f)"
        have g: "Arr f  Arr ?g  Dom ?g = Cod f"
          using 1 Id_in_Hom
          by (intro conjI, simp_all)
        have "COMP ?g f = MkArr (Dom f) (Dom f) (Map f)"
          using g COMP_def Comp_Id_Hom by auto
        moreover have "COMP ?g f = ?g"
        proof -
          have "COMP ?g f  null"
            using g 1 COMP_def null_char by simp
          thus ?thesis
            using f ide_def by blast
        qed
        ultimately show ?thesis by simp
      qed
      ultimately show "Ide f" by auto
    qed

    lemma ide_MkIde [simp]:
    assumes "A  Obj"
    shows "ide (MkIde A)"
      using assms ide_char Id_in_Hom by simp

    lemma in_domains_char:
    shows "a  domains f  Arr f  a = MkIde (Dom f)"
    proof
      assume a: "a  domains f"
      have "Ide a"
        using a domains_def ide_char COMP_def null_char by auto
      moreover have "Arr f  Dom f = Cod a"
      proof -
        have "COMP f a  null"
          using a domains_def by simp
        thus ?thesis
          using a domains_def COMP_def [of f a] null_char by metis
      qed
      ultimately show "Arr f  a = MkIde (Dom f)"
        by (cases a, auto)
      next
      assume a: "Arr f  a = MkIde (Dom f)"
      show "a  domains f"
        using a Id_in_Hom COMP_def null_char domains_def by auto
    qed

    lemma in_codomains_char:
    shows "b  codomains f  Arr f  b = MkIde (Cod f)"
    proof
      assume b: "b  codomains f"
      have "Ide b"
        using b codomains_def ide_char COMP_def null_char by auto
      moreover have "Arr f  Dom b = Cod f"
      proof -
        have "COMP b f  null"
          using b codomains_def by simp
        thus ?thesis
          using b codomains_def COMP_def [of b f] null_char by metis
      qed
      ultimately show "Arr f  b = MkIde (Cod f)"
        by (cases b, auto)
      next
      assume b: "Arr f  b = MkIde (Cod f)"
      show "b  codomains f"
        using b Id_in_Hom COMP_def null_char codomains_def by auto
    qed

    lemma arr_char:
    shows "arr f  Arr f"
      using arr_def in_domains_char in_codomains_char by auto

    lemma arrI:
    assumes "f  Null" and "Dom f  Obj" "Cod f  Obj" "Map f  Hom (Dom f) (Cod f)"
    shows "arr f"
      using assms arr_char by blast

    lemma arrE:
    assumes "arr f"
    and " f  Null; Dom f  Obj; Cod f  Obj; Map f  Hom (Dom f) (Cod f)   T"
    shows T
      using assms arr_char by simp

    lemma arr_MkArr [simp]:
    assumes "A  Obj" and "B  Obj" and "f  Hom A B"
    shows "arr (MkArr A B f)"
      using assms arr_char by simp

    lemma MkArr_Map:
    assumes "arr f"
    shows "MkArr (Dom f) (Cod f) (Map f) = f"
      using assms arr_char by (cases f, auto)

    lemma Arr_comp:
    assumes "arr f" and "arr g" and "Dom g = Cod f"
    shows "Arr (COMP g f)"
      unfolding COMP_def
      using assms arr_char Comp_in_Hom by simp

    lemma Dom_comp [simp]:
    assumes "arr f" and "arr g" and "Dom g = Cod f"
    shows "Dom (COMP g f) = Dom f"
      unfolding COMP_def
      using assms arr_char by simp

    lemma Cod_comp [simp]:
    assumes "arr f" and "arr g" and "Dom g = Cod f"
    shows "Cod (COMP g f) = Cod g"
      unfolding COMP_def
      using assms arr_char by simp

    lemma Map_comp [simp]:
    assumes "arr f" and "arr g" and "Dom g = Cod f"
    shows "Map (COMP g f) = Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f)"
      unfolding COMP_def
      using assms arr_char by simp

    lemma seq_char:
    shows "seq g f  arr f  arr g  Dom g = Cod f"
      using arr_char not_arr_null null_char COMP_def Arr_comp by metis

    interpretation category COMP
    proof
      show "g f. COMP g f  null  seq g f"
        using arr_char COMP_def null_char Comp_in_Hom by auto
      show 1: "f. (domains f  {}) = (codomains f  {})"
        using in_domains_char in_codomains_char by auto
      show "f g h. seq h g  seq (COMP h g) f  seq g f"
        by (auto simp add: seq_char)
      show "f g h. seq h (COMP g f)  seq g f  seq h g"
        using seq_char COMP_def Comp_in_Hom by (metis Cod_comp)
      show "f g h. seq g f  seq h g  seq (COMP h g) f"
        using Comp_in_Hom
        by (auto simp add: COMP_def seq_char)
      show "g f h. seq g f  seq h g  COMP (COMP h g) f = COMP h (COMP g f)"
        using seq_char COMP_def Comp_assoc Comp_in_Hom Dom_comp Cod_comp Map_comp
        by auto
    qed

    proposition is_category:
    shows "category COMP"
      ..

    text ‹
      Functions Dom›, Cod›, and Map› establish a correspondence between the
      arrows of the constructed category and the elements of the originally given
      parameters Obj› and Hom›.
    ›

    lemma Dom_in_Obj:
    assumes "arr f"
    shows "Dom f  Obj"
      using assms arr_char by simp

    lemma Cod_in_Obj:
    assumes "arr f"
    shows "Cod f  Obj"
      using assms arr_char by simp

    lemma Map_in_Hom:
    assumes "arr f"
    shows "Map f  Hom (Dom f) (Cod f)"
      using assms arr_char by simp

    lemma MkArr_in_hom:
    assumes "A  Obj" and "B  Obj" and "f  Hom A B"
    shows "in_hom (MkArr A B f) (MkIde A) (MkIde B)"
      using assms arr_char ide_MkIde
      by (simp add: in_codomains_char in_domains_char in_hom_def)

    text ‹
      The next few results show that domains, codomains, and composition in the constructed
      category are as expected according to the just-given correspondence.
    ›

    lemma dom_char:
    shows "dom f = (if arr f then MkIde (Dom f) else null)"
      using dom_def in_domains_char dom_in_domains has_domain_iff_arr by auto

    lemma cod_char:
    shows "cod f = (if arr f then MkIde (Cod f) else null)"
      using cod_def in_codomains_char cod_in_codomains has_codomain_iff_arr by auto

    lemma comp_char:
    shows "COMP g f = (if seq g f then
                         MkArr (Dom f) (Cod g) (Comp (Cod g) (Dom g) (Dom f) (Map g) (Map f))
                       else
                         null)"
      using COMP_def seq_char arr_char null_char by auto

    lemma in_hom_char:
    shows "in_hom f a b  arr f  ide a  ide b  Dom f = Dom a  Cod f = Dom b"
    proof
      show "in_hom f a b  arr f  ide a  ide b  Dom f = Dom a  Cod f = Dom b"
        using arr_char dom_char cod_char by auto
      show "arr f  ide a  ide b  Dom f = Dom a  Cod f = Dom b  in_hom f a b"
        using arr_char dom_char cod_char ide_char Id_in_Hom MkArr_Map in_homI by metis
    qed

    lemma Dom_dom [simp]:
    assumes "arr f"
    shows "Dom (dom f) = Dom f"
      using assms MkArr_Map dom_char by simp

    lemma Cod_dom [simp]:
    assumes "arr f"
    shows "Cod (dom f) = Dom f"
      using assms MkArr_Map dom_char by simp

    lemma Dom_cod [simp]:
    assumes "arr f"
    shows "Dom (cod f) = Cod f"
      using assms MkArr_Map cod_char by simp

    lemma Cod_cod [simp]:
    assumes "arr f"
    shows "Cod (cod f) = Cod f"
      using assms MkArr_Map cod_char by simp

    lemma Map_dom [simp]:
    assumes "arr f"
    shows "Map (dom f) = Id (Dom f)"
      using assms MkArr_Map dom_char by simp

    lemma Map_cod [simp]:
    assumes "arr f"
    shows "Map (cod f) = Id (Cod f)"
      using assms MkArr_Map cod_char by simp

    lemma Map_ide:
    assumes "ide a"
    shows "Map a = Id (Dom a)" and "Map a = Id (Cod a)"
      using assms ide_char dom_char [of a] Map_dom Map_cod ideD(1) by metis+

    (*
     * TODO: The next two ought to be simps, but they cause looping when they find themselves
     * in combination with dom_char and cod_char.
     *)
    lemma MkIde_Dom:
    assumes "arr a"
    shows "MkIde (Dom a) = dom a"
      using assms arr_char dom_char by (cases a, auto)

    lemma MkIde_Cod:
    assumes "arr a"
    shows "MkIde (Cod a) = cod a"
      using assms arr_char cod_char by (cases a, auto)

    lemma MkIde_Dom' [simp]:
    assumes "ide a"
    shows "MkIde (Dom a) = a"
      using assms MkIde_Dom by simp

    lemma MkIde_Cod' [simp]:
    assumes "ide a"
    shows "MkIde (Cod a) = a"
      using assms MkIde_Cod by simp

    lemma dom_MkArr [simp]:
    assumes "arr (MkArr A B F)"
    shows "dom (MkArr A B F) = MkIde A"
      using assms dom_char by simp

    lemma cod_MkArr [simp]:
    assumes "arr (MkArr A B F)"
    shows "cod (MkArr A B F) = MkIde B"
      using assms cod_char by simp

    lemma comp_MkArr [simp]:
    assumes "arr (MkArr A B F)" and "arr (MkArr B C G)"
    shows "COMP (MkArr B C G) (MkArr A B F) = MkArr A C (Comp C B A G F)"
      using assms comp_char [of "MkArr B C G" "MkArr A B F"] by simp

    text ‹
      The set Obj› of ``objects'' given as a parameter is in bijective correspondence
      (via function MkIde›) with the set of identities of the resulting category.
    ›

    proposition bij_betw_ide_Obj:
    shows "MkIde  Obj  Collect ide"
    and "Dom  Collect ide  Obj"
    and "A  Obj  Dom (MkIde A) = A"
    and "a  Collect ide  MkIde (Dom a) = a"
    and "bij_betw Dom (Collect ide) Obj"
    proof -
      show "MkIde  Obj  Collect ide"
        using ide_MkIde by simp
      moreover show "Dom  Collect ide  Obj"
        using arr_char ideD(1) by simp
      moreover show "A. A  Obj  Dom (MkIde A) = A"
        by simp
      moreover show "a. a  Collect ide  MkIde (Dom a) = a"
        using MkIde_Dom by simp
      ultimately show "bij_betw Dom (Collect ide) Obj"
        using bij_betwI by blast
    qed

    text ‹
      For each pair of identities a› and b›, the set Hom (Dom a) (Dom b)› is in
      bijective correspondence (via function MkArr (Dom a) (Dom b)›) with the
      ``hom-set'' hom a b› of the resulting category.
    ›

    proposition bij_betw_hom_Hom:
    assumes "ide a" and "ide b"
    shows "Map  hom a b  Hom (Dom a) (Dom b)"
    and "MkArr (Dom a) (Dom b)  Hom (Dom a) (Dom b)  hom a b"
    and "f. f  hom a b  MkArr (Dom a) (Dom b) (Map f) = f"
    and "F. F  Hom (Dom a) (Dom b)  Map (MkArr (Dom a) (Dom b) F) = F"
    and "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
    proof -
      show "Map  hom a b  Hom (Dom a) (Dom b)"
        using Map_in_Hom cod_char dom_char in_hom_char by fastforce
      moreover show "MkArr (Dom a) (Dom b)  Hom (Dom a) (Dom b)  hom a b"
        using assms Dom_in_Obj MkArr_in_hom [of "Dom a" "Dom b"] by simp
      moreover show "f. f  hom a b  MkArr (Dom a) (Dom b) (Map f) = f"
        using MkArr_Map by auto
      moreover show "F. F  Hom (Dom a) (Dom b)
                             Map (MkArr (Dom a) (Dom b) F) = F"
        by simp
      ultimately show "bij_betw Map (hom a b) (Hom (Dom a) (Dom b))"
        using bij_betwI by blast
    qed

    lemma arr_eqI:
    assumes "arr t" and "arr t'" and "Dom t = Dom t'" and "Cod t = Cod t'" and "Map t = Map t'"
    shows "t = t'"
      using assms MkArr_Map by metis

  end

  sublocale concrete_category  category COMP
    using is_category by auto

end

Theory FreeCategory

(*  Title:       FreeCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter FreeCategory

theory FreeCategory
imports Category ConcreteCategory
begin

  text‹
    This theory defines locales for constructing the free category generated by
    a graph, as well as some special cases, including the discrete category generated
    by a set of objects, the ``quiver'' generated by a set of arrows, and a ``parallel pair''
    of arrows, which is the diagram shape required for equalizers.
    Other diagram shapes can be constructed in a similar fashion.
›

  section Graphs

  text‹
    The following locale gives a definition of graphs in a traditional style.
›

  locale graph =
  fixes Obj :: "'obj set"
  and Arr :: "'arr set"
  and Dom :: "'arr  'obj"
  and Cod :: "'arr  'obj"
  assumes dom_is_obj: "x  Arr  Dom x  Obj"
  and cod_is_obj: "x  Arr  Cod x  Obj"
  begin

    text‹
      The list of arrows @{term p} forms a path from object @{term x} to object @{term y}
      if the domains and codomains of the arrows match up in the expected way.
›

    definition path
    where "path x y p  (p = []  x = y  x  Obj) 
                        (p  []  x = Dom (hd p)  y = Cod (last p) 
                        (n. n  0  n < length p  nth p n  Arr) 
                        (n. n  0  n < (length p)-1  Cod (nth p n) = Dom (nth p (n+1))))"

    lemma path_Obj:
    assumes "x  Obj"
    shows "path x x []"
      using assms path_def by simp

    lemma path_single_Arr:
    assumes "x  Arr"
    shows "path (Dom x) (Cod x) [x]"
      using assms path_def by simp

    lemma path_concat:
    assumes "path x y p" and "path y z q"
    shows "path x z (p @ q)"
    proof -
      have "p = []  q = []  ?thesis"
        using assms path_def by auto
      moreover have "p  []  q  []  ?thesis"
      proof -
        assume pq: "p  []  q  []"
        have Cod_last: "Cod (last p) = Cod (nth (p @ q) ((length p)-1))"
          using assms pq by (simp add: last_conv_nth nth_append)
        moreover have Dom_hd: "Dom (hd q) = Dom (nth (p @ q) (length p))"
          using assms pq by (simp add: hd_conv_nth less_not_refl2 nth_append)
        show ?thesis
        proof -
          have 1: "n. n  0  n < length (p @ q)  nth (p @ q) n  Arr"
          proof -
            fix n
            assume n: "n  0  n < length (p @ q)"
            have "(n  0  n < length p)  (n  length p  n < length (p @ q))"
              using n by auto
            thus "nth (p @ q) n  Arr"
              using assms pq nth_append path_def le_add_diff_inverse length_append
                    less_eq_nat.simps(1) nat_add_left_cancel_less
              by metis
          qed
          have 2: "n. n  0  n < length (p @ q) - 1 
                                    Cod (nth (p @ q) n) = Dom (nth (p @ q) (n+1))"
          proof -
            fix n
            assume n: "n  0  n < length (p @ q) - 1"
            have 1: "(n  0  n < (length p) - 1)  (n  length p  n < length (p @ q) - 1)
                        n = (length p) - 1"
              using n by auto
            thus "Cod (nth (p @ q) n) = Dom (nth (p @ q) (n+1))"
            proof -
              have "n  0  n < (length p) - 1  ?thesis"
                using assms pq nth_append path_def by (metis add_lessD1 less_diff_conv)
              moreover have "n = (length p) - 1  ?thesis"
                using assms pq nth_append path_def Dom_hd Cod_last by simp
              moreover have "n  length p  n < length (p @ q) - 1  ?thesis"
              proof -
                assume 1: "n  length p  n < length (p @ q) - 1"
                have "Cod (nth (p @ q) n) = Cod (nth q (n - length p))"
                  using 1 nth_append leD by metis
                also have "... = Dom (nth q (n - length p + 1))"
                  using 1 assms(2) path_def by auto
                also have "... = Dom (nth (p @ q) (n + 1))"
                  using 1 nth_append
                  by (metis Nat.add_diff_assoc2 ex_least_nat_le le_0_eq le_add1 le_neq_implies_less
                            le_refl le_trans length_0_conv pq)
                finally show "Cod (nth (p @ q) n) = Dom (nth (p @ q) (n + 1))" by auto
              qed
              ultimately show ?thesis using 1 by auto
            qed
          qed
          show ?thesis
            unfolding path_def using assms pq path_def hd_append2 Cod_last Dom_hd 1 2
            by simp
        qed
      qed
      ultimately show ?thesis by auto
    qed

  end

  section "Free Categories"

  text‹
    The free category generated by a graph has as its arrows all triples @{term "MkArr x y p"},
    where @{term x} and @{term y} are objects and @{term p} is a path from @{term x} to @{term y}.
    We construct it here an instance of the general construction given by the
    @{locale concrete_category} locale.
›

  locale free_category =
    G: graph Obj Arr D C
  for Obj :: "'obj set"
  and Arr :: "'arr set"
  and D :: "'arr  'obj"
  and C :: "'arr  'obj"
  begin

    type_synonym ('o, 'a) arr = "('o, 'a list) concrete_category.arr"

    sublocale concrete_category Obj :: 'obj set› λx y. Collect (G.path x y)
      λ_. [] λ_ _ _ g f. f @ g
      using G.path_Obj G.path_concat
      by (unfold_locales, simp_all)

    abbreviation comp      (infixr "" 55)
    where "comp  COMP"
    notation in_hom     ("«_ : _  _»")

    abbreviation Path
    where "Path  Map"

    lemma arr_single [simp]:
    assumes "x  Arr"
    shows "arr (MkArr (D x) (C x) [x])"
      using assms
      by (simp add: G.cod_is_obj G.dom_is_obj G.path_single_Arr)

  end

  section "Discrete Categories"

  text‹
    A discrete category is a category in which every arrow is an identity.
    We could construct it as the free category generated by a graph with no
    arrows, but it is simpler just to apply the @{locale concrete_category}
    construction directly.
›

  locale discrete_category =
  fixes Obj :: "'obj set"
  begin

    type_synonym 'o arr = "('o, unit) concrete_category.arr"

    sublocale concrete_category Obj :: 'obj set› λx y. if x = y then {x} else {}
      λx. x λ_ _ x _ _. x
      apply unfold_locales
          apply simp_all
        apply (metis empty_iff)
       apply (metis empty_iff singletonD)
      by (metis empty_iff singletonD)

    abbreviation comp      (infixr "" 55)
    where "comp  COMP"
    notation in_hom        ("«_ : _  _»")

    lemma is_discrete:
    shows "arr f  ide f"
      using ide_char arr_char by simp

    lemma arr_char:
    shows "arr f  Dom f  Obj  f = MkIde (Dom f)"
      using is_discrete
      by (metis (no_types, lifting) cod_char dom_char ide_MkIde ide_char ide_char')

    lemma arr_char':
    shows "arr f  f  MkIde ` Obj"
      using arr_char image_iff by auto

    lemma dom_char:
    shows "dom f = (if arr f then f else null)"
      using dom_char is_discrete by simp

    lemma cod_char:
    shows "cod f = (if arr f then f else null)"
      using cod_char is_discrete by simp

    lemma in_hom_char:
    shows "«f : a  b»  arr f  f = a  f = b"
      using is_discrete by auto

    lemma seq_char:
    shows "seq g f  arr f  f = g"
      using is_discrete
      by (metis (no_types, lifting) comp_arr_dom seqE dom_char)
    
    lemma comp_char:
    shows "g  f = (if seq g f then f else null)"
    proof -
      have "¬ seq g f  ?thesis"
        using comp_char by presburger
      moreover have "seq g f  ?thesis"
        using seq_char comp_char comp_arr_ide is_discrete
        by (metis (no_types, lifting))
      ultimately show ?thesis by blast
    qed

  end

  text‹
    The empty category is the discrete category generated by an empty set of objects.
›

  locale empty_category =
    discrete_category "{} :: unit set"
  begin

    lemma is_empty:
    shows "¬arr f"
      using arr_char by simp

  end

  section "Quivers"

  text‹
    A quiver is a two-object category whose non-identity arrows all point in the
    same direction.  A quiver is specified by giving the set of these non-identity arrows.
›

  locale quiver =
  fixes Arr :: "'arr set"
  begin

    type_synonym 'a arr = "(unit, 'a) concrete_category.arr"

    sublocale free_category "{False, True}" Arr "λ_. False" "λ_. True"
      by (unfold_locales, simp_all)

    notation comp                  (infixr "" 55)
    notation in_hom                ("«_ : _  _»")

    definition Zero
    where "Zero  MkIde False"

    definition One
    where "One  MkIde True"

    definition fromArr
    where "fromArr x  if x  Arr then MkArr False True [x] else null"

    definition toArr
    where "toArr f  hd (Path f)"

    lemma ide_char:
    shows "ide f  f = Zero  f = One"
    proof -
      have "ide f  f = MkIde False  f = MkIde True"
        using ide_char concrete_category.MkIde_Dom' concrete_category_axioms by fastforce
      thus ?thesis
        using comp_def Zero_def One_def by simp
    qed

    lemma arr_char':
    shows "arr f  f =
           MkIde False  f = MkIde True  f  (λx. MkArr False True [x]) ` Arr"
    proof
      assume f: "f = MkIde False  f = MkIde True  f  (λx. MkArr False True [x]) ` Arr"
      show "arr f" using f by auto
      next
      assume f: "arr f"
      have "¬(f = MkIde False  f = MkIde True)  f  (λx. MkArr False True [x]) ` Arr"
      proof -
        assume f': "¬(f = MkIde False  f = MkIde True)"
        have 0: "Dom f = False  Cod f = True"
          using f f' arr_char G.path_def MkArr_Map by fastforce
        have 1: "f = MkArr False True (Path f)"
          using f 0 arr_char MkArr_Map by force
        moreover have "length (Path f) = 1"
        proof -
          have "length (Path f)  0"
            using f f' 0 arr_char G.path_def by simp
          moreover have "x y p. length p > 1  ¬ G.path x y p"
            using G.path_def less_diff_conv by fastforce
          ultimately show ?thesis
            using f arr_char
            by (metis less_one linorder_neqE_nat mem_Collect_eq)
        qed
        moreover have "p. length p = 1  (x. p = [x])"
          by (auto simp: length_Suc_conv)
        ultimately have "x. x  Arr  Path f = [x]"
          using f G.path_def arr_char
          by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) le_eq_less_or_eq
              less_numeral_extra(1) mem_Collect_eq nth_Cons_0)
        thus "f  (λx. MkArr False True [x]) ` Arr"
          using 1 by auto
      qed
      thus "f = MkIde False  f = MkIde True  f  (λx. MkArr False True [x]) ` Arr"
        by auto
    qed

    lemma arr_char:
    shows "arr f  f = Zero  f = One  f  fromArr ` Arr"
      using arr_char' Zero_def One_def fromArr_def by simp

    lemma dom_char:
    shows "dom f = (if arr f then
                      if f = One then One else Zero
                    else null)"
    proof -
      have "¬ arr f  ?thesis"
        using dom_char by simp
      moreover have "arr f  ?thesis"
      proof -
        assume f: "arr f"
        have 1: "dom f = MkIde (Dom f)"
          using f dom_char by simp
        have "f = One  ?thesis"
          using f 1 One_def by (metis (full_types) Dom.simps(1))
        moreover have "f = Zero  ?thesis"
          using f 1 Zero_def by (metis (full_types) Dom.simps(1))
        moreover have "f  fromArr ` Arr  ?thesis"
          using f fromArr_def G.path_def Zero_def calculation(1) by auto
        ultimately show ?thesis
          using f arr_char by blast
      qed
      ultimately show ?thesis by blast
    qed

    lemma cod_char:
    shows "cod f = (if arr f then
                      if f = Zero then Zero else One
                    else null)"
    proof -
      have "¬ arr f  ?thesis"
        using cod_char by simp
      moreover have "arr f  ?thesis"
      proof -
        assume f: "arr f"
        have 1: "cod f = MkIde (Cod f)"
          using f cod_char by simp
        have "f = One  ?thesis"
          using f 1 One_def by (metis (full_types) Cod.simps(1) f)
        moreover have "f = Zero  ?thesis"
          using f 1 Zero_def by (metis (full_types) Cod.simps(1) f)
        moreover have "f  fromArr ` Arr  ?thesis"
          using f fromArr_def G.path_def One_def calculation(2) by auto
        ultimately show ?thesis
          using f arr_char by blast
      qed
      ultimately show ?thesis by blast
    qed

    lemma seq_char:
    shows "seq g f  arr g  arr f  ((f = Zero  g  One)  (f  Zero  g = One))"
    proof
      assume gf: "arr g  arr f  ((f = Zero  g  One)  (f  Zero  g = One))"
      show "seq g f"
        using gf dom_char cod_char by auto
      next
      assume gf: "seq g f"
      hence 1: "arr f  arr g  dom g = cod f" by auto
      have "Cod f = False  f = Zero"
        using gf 1 arr_char [of f] G.path_def Zero_def One_def cod_char Dom_cod
        by (metis (no_types, lifting) Dom.simps(1))
      moreover have "Cod f = True  g = One"
        using gf 1 arr_char [of f] G.path_def Zero_def One_def dom_char Dom_cod
        by (metis (no_types, lifting) Dom.simps(1))
      moreover have "¬(f = MkIde False  g = MkIde True)"
        using 1 by auto
      ultimately show "arr g  arr f  ((f = Zero  g  One)  (f  Zero  g = One))"
        using gf arr_char One_def Zero_def by blast
    qed

    lemma not_ide_fromArr:
    shows "¬ ide (fromArr x)"
      using fromArr_def ide_char ide_def Zero_def One_def
      by (metis Cod.simps(1) Dom.simps(1))

    lemma in_hom_char:
    shows "«f : a  b»  (a = Zero  b = Zero  f = Zero) 
                            (a = One  b = One  f = One) 
                            (a = Zero  b = One  f  fromArr ` Arr)"
    proof -
      have "f = Zero  ?thesis"
        using arr_char' [of f] ide_char'
        by (metis (no_types, lifting) Zero_def category.in_homE category.in_homI
            cod_MkArr dom_MkArr imageE is_category not_ide_fromArr)
      moreover have "f = One  ?thesis"
        using arr_char' [of f] ide_char'
        by (metis (no_types, lifting) One_def category.in_homE category.in_homI
            cod_MkArr dom_MkArr image_iff is_category not_ide_fromArr)
      moreover have "f  fromArr ` Arr  ?thesis"
      proof -
        assume f: "f  fromArr ` Arr"
        have 1: "arr f" using f arr_char by simp
        moreover have "dom f = Zero  cod f = One"
          using f 1 arr_char dom_char cod_char fromArr_def
          by (metis (no_types, lifting) ide_char imageE not_ide_fromArr)
        ultimately have "in_hom f Zero One" by auto
        thus "in_hom f a b  (a = Zero  b = Zero  f = Zero 
                                           a = One  b = One  f = One 
                                           a = Zero  b = One  f  fromArr ` Arr)"
          using f ide_char by auto
      qed
      ultimately show ?thesis
        using arr_char [of f] by fast
    qed

    lemma Zero_not_eq_One [simp]:
    shows "Zero  One"
      by (simp add: One_def Zero_def)

    lemma Zero_not_eq_fromArr [simp]:
    shows "Zero  fromArr ` Arr"
      using ide_char not_ide_fromArr
      by (metis (no_types, lifting) image_iff)

    lemma One_not_eq_fromArr [simp]:
    shows "One  fromArr ` Arr"
      using ide_char not_ide_fromArr
      by (metis (no_types, lifting) image_iff)

    lemma comp_char:
    shows "g  f = (if seq g f then
                      if f = Zero then g else if g = One then f else null
                    else null)"
    proof -
      have "seq g f  f = Zero  g  f = g"
        using seq_char comp_char [of g f] Zero_def dom_char cod_char comp_arr_dom
        by auto
      moreover have "seq g f  g = One  g  f = f"
        using seq_char comp_char [of g f] One_def dom_char cod_char comp_cod_arr
        by simp
      moreover have "seq g f  f  Zero  g  One  g  f = null"
        using seq_char Zero_def One_def by simp
      moreover have "¬seq g f  g  f = null"
        using comp_char ext by fastforce
      ultimately show ?thesis by argo
    qed

    lemma comp_simp [simp]:
    assumes "seq g f"
    shows "f = Zero  g  f = g"
    and "g = One  g  f = f"
      using assms seq_char comp_char by metis+

    lemma arr_fromArr:
    assumes "x  Arr"
    shows "arr (fromArr x)"
      using assms fromArr_def arr_char image_eqI by simp

    lemma toArr_in_Arr:
    assumes "arr f" and "¬ide f"
    shows "toArr f  Arr"
    proof -
      have "a. a  Arr  Path (fromArr a) = [a]"
        using fromArr_def arr_char by simp
      hence "hd (Path f)  Arr"
        using assms arr_char ide_char by auto
      thus ?thesis
        by (simp add: toArr_def)
    qed

    lemma toArr_fromArr [simp]:
    assumes "x  Arr"
    shows "toArr (fromArr x) = x"
      using assms fromArr_def toArr_def
      by (simp add: toArr_def)

    lemma fromArr_toArr [simp]:
    assumes "arr f" and "¬ide f"
    shows "fromArr (toArr f) = f"
      using assms fromArr_def toArr_def arr_char ide_char toArr_fromArr by auto

  end

  section "Parallel Pairs"

  text‹
    A parallel pair is a quiver with two non-identity arrows.
    It is important in the definition of equalizers.
›

  locale parallel_pair =
    quiver "{False, True} :: bool set"
  begin

    typedef arr = "UNIV :: bool quiver.arr set" ..

    definition j0
    where "j0  fromArr False"

    definition j1
    where "j1  fromArr True"

    lemma arr_char:
    shows "arr f  f = Zero  f = One  f = j0  f = j1"
      using arr_char j0_def j1_def by simp

    lemma dom_char:
    shows "dom f = (if f = j0  f = j1 then Zero else if arr f then f else null)"
      using arr_char dom_char j0_def j1_def
      by (metis ide_char not_ide_fromArr)

    lemma cod_char:
    shows "cod f = (if f = j0  f = j1 then One else if arr f then f else null)"
      using arr_char cod_char j0_def j1_def
      by (metis ide_char not_ide_fromArr)

    lemma j0_not_eq_j1 [simp]:
    shows "j0  j1"
      using j0_def j1_def
      by (metis insert_iff toArr_fromArr)

    lemma Zero_not_eq_j0 [simp]:
    shows "Zero  j0"
      using Zero_def j0_def Zero_not_eq_fromArr by auto

    lemma Zero_not_eq_j1 [simp]:
    shows "Zero  j1"
      using Zero_def j1_def Zero_not_eq_fromArr by auto

    lemma One_not_eq_j0 [simp]:
    shows "One  j0"
      using One_def j0_def One_not_eq_fromArr by auto

    lemma One_not_eq_j1 [simp]:
    shows "One  j1"
      using One_def j1_def One_not_eq_fromArr by auto

    lemma dom_simp [simp]:
    shows "dom Zero = Zero"
    and "dom One = One"
    and "dom j0 = Zero"
    and "dom j1 = Zero"
      using dom_char arr_char by auto

    lemma cod_simp [simp]:
    shows "cod Zero = Zero"
    and "cod One = One"
    and "cod j0 = One"
    and "cod j1 = One"
      using cod_char arr_char by auto

  end

end

Theory DiscreteCategory

(*  Title:       DiscreteCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter DiscreteCategory

theory DiscreteCategory
imports Category
begin

  text‹
    The locale defined here permits us to construct a discrete category having
    a specified set of objects, assuming that the set does not exhaust the elements
    of its type.  In that case, we have the convenient situation that the arrows of
    the category can be directly identified with the elements of the given set,
    rather than having to pass between the two via tedious coercion maps.
    If it cannot be guaranteed that the given set is not the universal set at its type,
    then the more general discrete category construction defined (using coercions)
    in FreeCategory› can be used.
›

  locale discrete_category =
    fixes Obj :: "'a set"
    and Null :: 'a
    assumes Null_not_in_Obj: "Null  Obj"
  begin

    definition comp :: "'a comp"      (infixr "" 55)
    where "y  x  (if x  Obj  x = y then x else Null)"

    interpretation partial_magma comp
      apply unfold_locales
      using comp_def by metis

    lemma null_char:
    shows "null = Null"
      using comp_def null_def by auto

    lemma ide_char [iff]:
    shows "ide f  f  Obj"
      using comp_def null_char ide_def Null_not_in_Obj by auto

    lemma domains_char:
    shows "domains f = {x. x  Obj  x = f}"
      unfolding domains_def
      using ide_char ide_def comp_def null_char by metis

    theorem is_category:
    shows "category comp"
      using comp_def
      apply unfold_locales
      using arr_def null_char self_domain_iff_ide ide_char
           apply fastforce
      using null_char self_codomain_iff_ide domains_char codomains_def ide_char
          apply fastforce
         apply (metis not_arr_null null_char)
        apply (metis not_arr_null null_char)
      by auto

  end

  sublocale discrete_category  category comp
    using is_category by auto

  context discrete_category
  begin

    lemma arr_char [iff]:
    shows "arr f  f  Obj"
      using comp_def comp_cod_arr
      by (metis empty_iff has_codomain_iff_arr not_arr_null null_char self_codomain_iff_ide ide_char)

    lemma dom_char [simp]:
    shows "dom f = (if f  Obj then f else null)"
      using arr_def dom_def arr_char ideD(2) by auto

    lemma cod_char [simp]:
    shows "cod f = (if f  Obj then f else null)"
      using arr_def in_homE cod_def ideD(3) by auto

    lemma comp_char [simp]:
    shows "comp g f = (if f  Obj  f = g then f else null)"
      using comp_def null_char by auto

    lemma is_discrete:
    shows "ide = arr"
      using arr_char ide_char by auto

    lemma seq_char [iff]:
    shows "seq f g  ide f  f = g"
      using is_discrete by (metis (full_types) ide_def seqE)

  end

end

Theory DualCategory

(*  Title:       DualCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter DualCategory

theory DualCategory
imports Category
begin

  text‹
    The locale defined here constructs the dual (opposite) of a category.
    The arrows of the dual category are directly identified with the arrows of
    the given category and simplification rules are introduced that automatically
    eliminate notions defined for the dual category in favor of the corresponding
    notions on the original category.  This makes it easy to use the dual of
    a category in the same context as the category itself, without having to
    worry about whether an arrow belongs to the category or its dual.
›
    
  locale dual_category =
    C: category C
  for C :: "'a comp"     (infixr "" 55)
  begin

    definition comp      (infixr "op" 55)
    where "g op f  f  g"

    lemma comp_char [simp]:
    shows "g op f = f  g"
      using comp_def by auto

    interpretation partial_magma comp
      apply unfold_locales using comp_def C.ex_un_null by metis

    notation in_hom ("«_ : _  _»")

    lemma null_char [simp]:
    shows "null = C.null"
      by (metis C.comp_null(2) comp_null(2) comp_def)

    lemma ide_char [simp]:
    shows "ide a  C.ide a"
      unfolding ide_def C.ide_def by auto

    lemma domains_char:
    shows "domains f = C.codomains f"
      using C.codomains_def domains_def ide_char by auto

    lemma codomains_char:
    shows "codomains f = C.domains f"
      using C.domains_def codomains_def ide_char by auto

    interpretation category comp
      using C.has_domain_iff_arr C.has_codomain_iff_arr domains_char codomains_char null_char
            comp_def C.match_4 C.ext arr_def C.comp_assoc
      apply (unfold_locales, auto)
      using C.match_2 by metis

    lemma is_category:
    shows "category comp" ..

  end

  sublocale dual_category  category comp
    using is_category by auto

  context dual_category
  begin

    lemma dom_char [simp]:
    shows "dom f = C.cod f"
      by (simp add: C.cod_def dom_def domains_char)

    lemma cod_char [simp]:
    shows "cod f = C.dom f"
      by (simp add: C.dom_def cod_def codomains_char)

    lemma arr_char [simp]:
    shows "arr f  C.arr f"
      using C.has_codomain_iff_arr has_domain_iff_arr domains_char by auto

    lemma hom_char [simp]:
    shows "in_hom f b a  C.in_hom f a b"
      by force

    lemma seq_char [simp]:
    shows "seq g f = C.seq f g"
      by simp

  end

end

Theory EpiMonoIso

(*  Title:       EpiMonoIso
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter EpiMonoIso

theory EpiMonoIso
imports Category
begin

  text‹
    This theory defines and develops properties of epimorphisms, monomorphisms,
    isomorphisms, sections, and retractions.
›

  context category
  begin

     definition epi
     where "epi f = (arr f  inj_on (λg. g  f) {g. seq g f})"

     definition mono
     where "mono f = (arr f  inj_on (λg. f  g) {g. seq f g})"

     lemma epiI [intro]:
     assumes "arr f" and "g g'. seq g f  seq g' f  g  f = g'  f  g = g'"
     shows "epi f"
       using assms epi_def inj_on_def by blast

     lemma epi_implies_arr:
     assumes "epi f"
     shows "arr f"
       using assms epi_def by auto

     (*
      * TODO: epiE and monoE don't need both seq hypotheses.
      * Also, they are not stated in the form of elimination rules.
      *)

     lemma epiE [elim]:
     assumes "epi f"
     and "seq g f" and "seq g' f" and "g  f = g'  f"
     shows "g = g'"
       using assms unfolding epi_def inj_on_def by blast
       
     lemma monoI [intro]:
     assumes "arr g" and "f f'. seq g f  seq g f'  g  f = g  f'  f = f'"
     shows "mono g"
       using assms mono_def inj_on_def by blast

     lemma mono_implies_arr:
     assumes "mono f"
     shows "arr f"
       using assms mono_def by auto
       
     lemma monoE [elim]:
     assumes "mono g"
     and "seq g f" and "seq g f'" and "g  f = g  f'"
     shows "f' = f"
       using assms unfolding mono_def inj_on_def by blast

     definition inverse_arrows
     where "inverse_arrows f g  ide (g  f)  ide (f  g)"

     lemma inverse_arrowsI [intro]:
     assumes "ide (g  f)" and "ide (f  g)"
     shows "inverse_arrows f g"
       using assms inverse_arrows_def by blast

     lemma inverse_arrowsE [elim]:
     assumes "inverse_arrows f g"
     and " ide (g  f); ide (f  g)   T"
     shows "T"
       using assms inverse_arrows_def by blast

     lemma inverse_arrows_sym:
       shows "inverse_arrows f g  inverse_arrows g f"
       using inverse_arrows_def by auto

     lemma ide_self_inverse:
     assumes "ide a"
     shows "inverse_arrows a a"
       using assms by auto

     lemma inverse_arrow_unique:
     assumes "inverse_arrows f g" and "inverse_arrows f g'"
     shows "g = g'"
       using assms apply (elim inverse_arrowsE)
       by (metis comp_cod_arr ide_compE comp_assoc seqE)

     lemma inverse_arrows_compose:
     assumes "seq g f" and "inverse_arrows f f'" and "inverse_arrows g g'"
     shows "inverse_arrows (g  f) (f'  g')"
       using assms apply (elim inverse_arrowsE, intro inverse_arrowsI)
        apply (metis seqE comp_arr_dom ide_compE comp_assoc)
       by (metis seqE comp_arr_dom ide_compE comp_assoc)

     definition "section"
     where "section f  g. ide (g  f)"

     lemma sectionI [intro]:
     assumes "ide (g  f)"
     shows "section f"
       using assms section_def by auto

     lemma sectionE [elim]:
     assumes "section f"
     obtains g where "ide (g  f)"
       using assms section_def by blast

     definition retraction
     where "retraction g  f. ide (g  f)"

     lemma retractionI [intro]:
     assumes "ide (g  f)"
     shows "retraction g"
       using assms retraction_def by auto

     lemma retractionE [elim]:
     assumes "retraction g"
     obtains f where "ide (g  f)"
       using assms retraction_def by blast
       
     lemma section_is_mono:
     assumes "section g"
     shows "mono g"
     proof
       show "arr g" using assms section_def by blast
       from assms obtain h where h: "ide (h  g)" by blast
       have hg: "seq h g" using h by auto
       fix f f'
       assume "seq g f  seq g f'  g  f = g  f'"
       thus "f = f'"
         using hg h ide_compE seqE comp_assoc comp_cod_arr by metis
     qed

     lemma retraction_is_epi:
     assumes "retraction g"
     shows "epi g"
     proof
       show "arr g" using assms retraction_def by blast
       from assms obtain f where f: "ide (g  f)" by blast
       have gf: "seq g f" using f by auto
       fix h h'
       assume "seq h g  seq h' g  h  g = h'  g"
       thus "h = h'"
         using gf f ide_compE seqE comp_assoc comp_arr_dom by metis
     qed

     lemma section_retraction_compose:
     assumes "ide (e  m)" and "ide (e'  m')" and "seq m' m"
     shows "ide ((e  e')  (m'  m))"
       using assms seqI seqE ide_compE comp_assoc comp_arr_dom by metis

     lemma sections_compose [intro]:
     assumes "section m" and "section m'" and "seq m' m"
     shows "section (m'  m)"
       using assms section_def section_retraction_compose by metis

     lemma retractions_compose [intro]:
     assumes "retraction e" and "retraction e'" and "seq e' e"
     shows "retraction (e'  e)"
     proof -
       from assms(1-2) obtain m m'
       where *: "ide (e  m)  ide (e'  m')"
         using retraction_def by auto
       hence "seq m m'"
         using assms(3) by (metis seqE seqI ide_compE)
       with * show ?thesis
         using section_retraction_compose retractionI by blast
     qed
       
     lemma monos_compose [intro]:
     assumes "mono m" and "mono m'" and "seq m' m"
     shows "mono (m'  m)"
     proof -
       have "inj_on (λf. (m'  m)  f) {f. seq (m'  m) f}"
         unfolding inj_on_def
         using assms
         by (metis CollectD seqE monoE comp_assoc)
       thus ?thesis using assms(3) mono_def by force
     qed           

     lemma epis_compose [intro]:
     assumes "epi e" and "epi e'" and "seq e' e"
     shows "epi (e'  e)"
     proof -
       have "inj_on (λg. g  (e'  e)) {g. seq g (e'  e)}"
         unfolding inj_on_def
         using assms by (metis CollectD epiE match_2 comp_assoc)
       thus ?thesis using assms(3) epi_def by force
     qed           

     definition iso
     where "iso f  g. inverse_arrows f g"

     lemma isoI [intro]:
     assumes "inverse_arrows f g"
     shows "iso f"
       using assms iso_def by auto

     lemma isoE [elim]:
     assumes "iso f"
     obtains g where "inverse_arrows f g"
       using assms iso_def by blast

     lemma ide_is_iso [simp]:
     assumes "ide a"
     shows "iso a"
       using assms ide_self_inverse by auto

     lemma iso_is_arr:
     assumes "iso f"
     shows "arr f"
       using assms by blast

     lemma iso_is_section:
     assumes "iso f"
     shows "section f"
       using assms inverse_arrows_def by blast

     lemma iso_is_retraction:
     assumes "iso f"
     shows "retraction f"
       using assms inverse_arrows_def by blast

    lemma iso_iff_mono_and_retraction:
    shows "iso f  mono f  retraction f"
    proof
      show "iso f  mono f  retraction f"
        by (simp add: iso_is_retraction iso_is_section section_is_mono)
      show "mono f  retraction f  iso f"
      proof -
        assume f: "mono f  retraction f"
        from f obtain g where g: "ide (f  g)" by blast
        have "inverse_arrows f g"
          using f g comp_arr_dom comp_cod_arr comp_assoc inverse_arrowsI
          by (metis ide_char' ide_compE monoE mono_implies_arr)
        thus "iso f" by auto
      qed
    qed

    lemma iso_iff_section_and_epi:
    shows "iso f  section f  epi f"
    proof
      show "iso f  section f  epi f"
        by (simp add: iso_is_retraction iso_is_section retraction_is_epi)
      show "section f  epi f  iso f"
      proof -
        assume f: "section f  epi f"
        from f obtain g where g: "ide (g  f)" by blast
        have "inverse_arrows f g"
          using f g comp_arr_dom comp_cod_arr epi_implies_arr
                comp_assoc ide_compE inverse_arrowsI epiE ide_char'
          by metis
        thus "iso f" by auto
      qed
    qed

    lemma iso_iff_section_and_retraction:
    shows "iso f  section f  retraction f"
      using iso_is_retraction iso_is_section iso_iff_mono_and_retraction section_is_mono
      by auto

    lemma isos_compose [intro]:
    assumes "iso f" and "iso f'" and "seq f' f"
    shows "iso (f'  f)"
    proof -
      from assms(1) obtain g where g: "inverse_arrows f g" by blast
      from assms(2) obtain g' where g': "inverse_arrows f' g'" by blast
      have "inverse_arrows (f'  f) (g  g')"
        using assms g g inverse_arrowsI inverse_arrowsE section_retraction_compose
        by (simp add: g' inverse_arrows_compose)
      thus ?thesis using iso_def by auto
    qed

    lemma iso_cancel_left:
    assumes "iso f" and "f  g = f  g'" and "seq f g"
    shows "g = g'"
      using assms iso_is_section section_is_mono monoE by metis

    lemma iso_cancel_right:
    assumes "iso g" and "f  g = f'  g" and "seq f g" and "iso g"
    shows "f = f'"
      using assms iso_is_retraction retraction_is_epi epiE by metis

    definition isomorphic
    where "isomorphic a a' = (f. «f : a  a'»  iso f)"

    lemma isomorphicI [intro]:
    assumes "iso f"
    shows "isomorphic (dom f) (cod f)"
      using assms isomorphic_def iso_is_arr by blast

    lemma isomorphicE [elim]:
    assumes "isomorphic a a'"
    obtains f where "«f : a  a'»  iso f"
      using assms isomorphic_def by meson

    definition iso_in_hom  ("«_ : _  _»")
    where "iso_in_hom f a b  «f : a  b»  iso f"

    lemma iso_in_homI [intro]:
    assumes "«f : a  b»" and "iso f"
    shows "«f : a  b»"
      using assms iso_in_hom_def by simp

    lemma iso_in_homE [elim]:
    assumes "«f : a  b»"
    and "«f : a  b»; iso f  T"
    shows T
      using assms iso_in_hom_def by simp

    lemma isomorphicI':
    assumes "«f : a  b»"
    shows "isomorphic a b"
      using assms iso_in_hom_def isomorphic_def by auto

    lemma ide_iso_in_hom:
    assumes "ide a"
    shows "«a : a  a»"
      using assms by fastforce

    lemma comp_iso_in_hom [intro]:
    assumes "«f : a  b»" and "«g : b  c»"
    shows "«g  f : a  c»"
      using assms iso_in_hom_def by auto

    definition inv
    where "inv f = (SOME g. inverse_arrows f g)"

    lemma inv_is_inverse:
    assumes "iso f"
    shows "inverse_arrows f (inv f)"
      using assms inv_def someI [of "inverse_arrows f"] by auto

    lemma iso_inv_iso [intro, simp]:
    assumes "iso f"
    shows "iso (inv f)"
      using assms inv_is_inverse inverse_arrows_sym by blast

    lemma inverse_unique:
    assumes "inverse_arrows f g"
    shows "inv f = g"
      using assms inv_is_inverse inverse_arrow_unique isoI by auto

    lemma inv_ide [simp]:
    assumes "ide a"
    shows "inv a = a"
      using assms by (simp add: inverse_arrowsI inverse_unique)

    lemma inv_inv [simp]:
    assumes "iso f"
    shows "inv (inv f) = f"
      using assms inverse_arrows_sym inverse_unique by blast

    lemma comp_arr_inv:
    assumes "inverse_arrows f g"
    shows "f  g = dom g"
      using assms by auto

    lemma comp_inv_arr:
    assumes "inverse_arrows f g"
    shows "g  f = dom f"
      using assms by auto

    lemma comp_arr_inv':
    assumes "iso f"
    shows "f  inv f = cod f"
      using assms inv_is_inverse by blast

    lemma comp_inv_arr':
    assumes "iso f"
    shows "inv f  f = dom f"
      using assms inv_is_inverse by blast

    lemma inv_in_hom [simp]:
    assumes "iso f" and "«f : a  b»"
    shows "«inv f : b  a»"
      using assms inv_is_inverse seqE inverse_arrowsE
      by (metis ide_compE in_homE in_homI)

    lemma arr_inv [simp]:
    assumes "iso f"
    shows "arr (inv f)"
      using assms inv_in_hom by blast

    lemma dom_inv [simp]:
    assumes "iso f"
    shows "dom (inv f) = cod f"
      using assms inv_in_hom by blast

    lemma cod_inv [simp]:
    assumes "iso f"
    shows "cod (inv f) = dom f"
      using assms inv_in_hom by blast

    lemma inv_comp:
    assumes "iso f" and "iso g" and "seq g f"
    shows "inv (g  f) = inv f  inv g"
      using assms inv_is_inverse inverse_unique inverse_arrows_compose inverse_arrows_def
      by meson

    lemma isomorphic_reflexive:
    assumes "ide f"
    shows "isomorphic f f"
      unfolding isomorphic_def
      using assms ide_is_iso ide_in_hom by blast

    lemma isomorphic_symmetric:
    assumes "isomorphic f g"
    shows "isomorphic g f"
      using assms inv_in_hom by blast

    lemma isomorphic_transitive [trans]:
    assumes "isomorphic f g" and "isomorphic g h"
    shows "isomorphic f h"
      using assms isomorphic_def isos_compose by auto

    text ‹
      A section or retraction of an isomorphism is in fact an inverse.
›

    lemma section_retraction_of_iso:
    assumes "iso f"
    shows "ide (g  f)  inverse_arrows f g"
    and "ide (f  g)  inverse_arrows f g"
    proof -
      show "ide (g  f)  inverse_arrows f g"
        using assms
        by (metis comp_inv_arr' epiE ide_compE inv_is_inverse iso_iff_section_and_epi)
      show "ide (f  g)  inverse_arrows f g"
        using assms
        by (metis ide_compE comp_arr_inv' inv_is_inverse iso_iff_mono_and_retraction monoE)
    qed

    text ‹
      A situation that occurs frequently is that we have a commuting triangle,
      but we need the triangle obtained by inverting one side that is an isomorphism.
      The following fact streamlines this derivation.
›

    lemma invert_side_of_triangle:
    assumes "arr h" and "f  g = h"
    shows "iso f  seq (inv f) h  g = inv f  h"
    and "iso g  seq h (inv g)  f = h  inv g"
    proof -
      show "iso f  seq (inv f) h  g = inv f  h"
        by (metis assms seqE inv_is_inverse comp_cod_arr comp_inv_arr comp_assoc)
      show "iso g  seq h (inv g)  f = h  inv g"
        by (metis assms seqE inv_is_inverse comp_arr_dom comp_arr_inv dom_inv comp_assoc)
    qed

    text ‹
      A similar situation is where we have a commuting square and we want to
      invert two opposite sides.
›

    lemma invert_opposite_sides_of_square:
    assumes "seq f g" and "f  g = h  k"
    shows " iso f; iso k   seq g (inv k)  seq (inv f) h  g  inv k = inv f  h"
      by (metis assms invert_side_of_triangle comp_assoc)

    text ‹
      The following versions of inv_comp› provide information needed for repeated
      application to a composition of more than two arrows and seem often to be more
      useful.
›

    lemma inv_comp_left:
    assumes "iso (g  f)" and "iso g"
    shows "inv (g  f) = inv f  inv g" and "iso f"
    proof -
      have 1: "inv f = inv (g  f)  g"
      proof -
        have "inv (g  f)  g = inv (g  f)  inv (inv g)"
         using assms by simp
        also have "... = inv (inv g  g  f)"
          using assms inv_comp iso_is_arr by simp
        also have "... = inv ((inv g  g)  f)"
          using comp_assoc by simp
        also have "... = inv f"
          using assms comp_ide_arr invert_side_of_triangle(1) iso_is_arr comp_assoc
          by metis
        finally show ?thesis by simp
      qed
      show "inv (g  f) = inv f  inv g"
        using assms 1 comp_arr_dom comp_assoc
        by (metis arr_inv cod_comp dom_inv invert_side_of_triangle(2) iso_is_arr seqI)
      show "iso f"
        using assms 1 comp_assoc inv_is_inverse
        by (metis arr_inv invert_side_of_triangle(1) inv_inv iso_inv_iso isos_compose)
    qed

    lemma inv_comp_right:
    assumes "iso (g  f)" and "iso f"
    shows "inv (g  f) = inv f  inv g" and "iso g"
    proof -
      have 1: "inv g = f  inv (g  f)"
      proof -
        have "f  inv (g  f) = inv (inv f)  inv (g  f)"
          using assms by simp
        also have "... = inv ((g  f)  inv f)"
          using assms inv_comp iso_is_arr by simp
        also have "... = inv (g  f  inv f)"
          using comp_assoc by simp
        also have "... = inv g"
          using assms comp_arr_dom invert_side_of_triangle(2) iso_is_arr comp_assoc
          by metis
        finally show ?thesis by simp
      qed
      show "inv (g  f) = inv f  inv g"
        using assms 1 comp_cod_arr comp_assoc
        by (metis arr_inv cod_inv dom_comp seqI invert_side_of_triangle(1) iso_is_arr)
      show "iso g"
        using assms 1 comp_assoc inv_is_inverse
        by (metis arr_inv invert_side_of_triangle(2) inv_inv iso_inv_iso isos_compose)
    qed

  end

end


Theory InitialTerminal

(*  Title:       InitialTerminal
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter InitialTerminal

theory InitialTerminal
imports EpiMonoIso
begin

  text‹
    This theory defines the notions of initial and terminal object in a category
    and establishes some properties of these notions, including that when they exist
    they are unique up to isomorphism.
›

  context category
  begin

    definition initial
    where "initial a  ide a  (b. ide b  (∃!f. «f : a  b»))"

    definition terminal
    where "terminal b  ide b  (a. ide a  (∃!f. «f : a  b»))"
    
    abbreviation initial_arr
    where "initial_arr f  arr f  initial (dom f)"
    
    abbreviation terminal_arr
    where "terminal_arr f  arr f  terminal (cod f)"
    
    abbreviation point
    where "point f  arr f  terminal (dom f)"

    lemma initial_arr_unique:
    assumes "par f f'" and "initial_arr f" and "initial_arr f'"
    shows "f = f'"
      using assms in_homI initial_def ide_cod by blast

    lemma initialI [intro]:
    assumes "ide a" and "b. ide b  ∃!f. «f : a  b»"
    shows "initial a"
      using assms initial_def by auto

    lemma initialE [elim]:
    assumes "initial a" and "ide b"
    obtains f where "«f : a  b»" and "f'. «f' : a  b»  f' = f"
      using assms initial_def initial_arr_unique by meson
      
    lemma terminal_arr_unique:
    assumes "par f f'" and "terminal_arr f" and "terminal_arr f'"
    shows "f = f'"
      using assms in_homI terminal_def ide_dom by blast

    lemma terminalI [intro]:
    assumes "ide b" and "a. ide a  ∃!f. «f : a  b»"
    shows "terminal b"
      using assms terminal_def by auto

    lemma terminalE [elim]:
    assumes "terminal b" and "ide a"
    obtains f where "«f : a  b»" and "f'. «f' : a  b»  f' = f"
      using assms terminal_def terminal_arr_unique by meson

    theorem terminal_objs_isomorphic:
    assumes "terminal a" and "terminal b"
    shows "isomorphic a b"
    proof -
      from assms obtain f where f: "«f : a  b»"
        using terminal_def by meson
      from assms obtain g where g: "«g : b  a»"
        using terminal_def by meson
      have "iso f"
        using assms f g
        by (metis arr_iff_in_hom cod_comp retractionI sectionI seqI' terminal_def
            dom_comp in_homE iso_iff_section_and_retraction ide_in_hom)
      thus ?thesis using f by auto
    qed

    theorem initial_objs_isomorphic:
    assumes "initial a" and "initial b"
    shows "isomorphic a b"
    proof -
      from assms obtain f where f: "«f : a  b»" using initial_def by auto
      from assms obtain g where g: "«g : b  a»" using initial_def by auto
      have "iso f"
        using assms f g
        by (metis (no_types, lifting) arr_iff_in_hom cod_comp in_homE initial_def
            retractionI sectionI dom_comp iso_iff_section_and_retraction ide_in_hom seqI')
      thus ?thesis
        using f by auto
    qed

    lemma point_is_mono:
    assumes "point f"
    shows "mono f"
    proof -
      have "ide (cod f)" using assms by auto
      from this obtain t where t: "«t: cod f  dom f»"
        using assms terminal_def by blast
      thus ?thesis
        using assms terminal_def monoI
        by (metis seqE in_homI dom_comp ide_dom terminal_def)
    qed
      
  end

end

Theory Functor

(*  Title:       Functor
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter Functor

theory Functor
imports Category ConcreteCategory DualCategory InitialTerminal
begin

  text‹
    One advantage of the ``object-free'' definition of category is that a functor
    from category A› to category B› is simply a function from the type
    of arrows of A› to the type of arrows of B› that satisfies certain
    conditions: namely, that arrows are mapped to arrows, non-arrows are mapped to
    null›, and domains, codomains, and composition of arrows are preserved.
›

  locale "functor" =
    A: category A +
    B: category B
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and F :: "'a  'b" +
  assumes is_extensional: "¬A.arr f  F f = B.null"
  and preserves_arr: "A.arr f  B.arr (F f)"
  and preserves_dom [iff]: "A.arr f  B.dom (F f) = F (A.dom f)"
  and preserves_cod [iff]: "A.arr f  B.cod (F f) = F (A.cod f)"
  and preserves_comp [iff]: "A.seq g f  F (g A f) = F g B F f"
  begin

    notation A.in_hom     ("«_ : _ A _»")
    notation B.in_hom     ("«_ : _ B _»")

    lemma preserves_hom [intro]:
    assumes "«f : a A b»"
    shows "«F f : F a B F b»"
      using assms B.in_homI
      by (metis A.in_homE preserves_arr preserves_cod preserves_dom)

    text‹
      The following, which is made possible through the presence of null›,
      allows us to infer that the subterm @{term f} denotes an arrow if the
      term @{term "F f"} denotes an arrow.  This is very useful, because otherwise
      doing anything with @{term f} would require a separate proof that it is an arrow
      by some other means.
›

    lemma preserves_reflects_arr [iff]:
    shows "B.arr (F f)  A.arr f"
      using preserves_arr is_extensional B.not_arr_null by metis

    lemma preserves_seq [intro]:
    assumes "A.seq g f"
    shows "B.seq (F g) (F f)"
      using assms by auto

    lemma preserves_ide [simp]:
    assumes "A.ide a"
    shows "B.ide (F a)"
      using assms A.ide_in_hom B.ide_in_hom by auto

    lemma preserves_iso [simp]:
    assumes "A.iso f"
    shows "B.iso (F f)"
      using assms A.inverse_arrowsE
      apply (elim A.isoE A.inverse_arrowsE A.seqE A.ide_compE)
      by (metis A.arr_dom_iff_arr B.ide_dom B.inverse_arrows_def B.isoI preserves_arr
                preserves_comp preserves_dom)

    lemma preserves_section_retraction:
    assumes "A.ide (A e m)"
    shows "B.ide (B (F e) (F m))"
      using assms by (metis A.ide_compE preserves_comp preserves_ide)

    lemma preserves_section:
    assumes "A.section m"
    shows "B.section (F m)"
      using assms preserves_section_retraction by blast

    lemma preserves_retraction:
    assumes "A.retraction e"
    shows "B.retraction (F e)"
      using assms preserves_section_retraction by blast

    lemma preserves_inverse_arrows:
    assumes "A.inverse_arrows f g"
    shows "B.inverse_arrows (F f) (F g)"
      using assms A.inverse_arrows_def B.inverse_arrows_def preserves_section_retraction
      by simp

    lemma preserves_inv:
    assumes "A.iso f"
    shows "F (A.inv f) = B.inv (F f)"
      using assms preserves_inverse_arrows A.inv_is_inverse B.inv_is_inverse
            B.inverse_arrow_unique
      by blast

    lemma preserves_iso_in_hom [intro]:
    assumes "A.iso_in_hom f a b"
    shows "B.iso_in_hom (F f) (F a) (F b)"
      using assms preserves_hom preserves_iso by blast

  end

  locale endofunctor =
    "functor" A A F
  for A :: "'a comp"     (infixr "" 55)
  and F :: "'a  'a"

  locale faithful_functor = "functor" A B F
  for A :: "'a comp"
  and B :: "'b comp"
  and F :: "'a  'b" +
  assumes is_faithful: " A.par f f'; F f = F f'   f = f'"
  begin

    lemma locally_reflects_ide:
    assumes "«f : a A a»" and "B.ide (F f)"
    shows "A.ide f"
      using assms is_faithful
      by (metis A.arr_dom_iff_arr A.cod_dom A.dom_dom A.in_homE B.comp_ide_self
          B.ide_self_inverse B.comp_arr_inv A.ide_cod preserves_dom)

  end

  locale full_functor = "functor" A B F
  for A :: "'a comp"
  and B :: "'b comp"
  and F :: "'a  'b" +
  assumes is_full: " A.ide a; A.ide a'; «g : F a' B F a»   f. «f : a' A a»  F f = g"

  locale fully_faithful_functor =
    faithful_functor A B F +
    full_functor A B F
  for A :: "'a comp"
  and B :: "'b comp"
  and F :: "'a  'b"
  begin

    lemma reflects_iso:
    assumes "«f : a' A a»" and "B.iso (F f)"
    shows "A.iso f"
    proof -
      from assms obtain g' where g': "B.inverse_arrows (F f) g'" by blast
      have 1: "«g' : F a B F a'»"
        using assms g' by (metis B.inv_in_hom B.inverse_unique preserves_hom)
      from this obtain g where g: "«g : a A a'»  F g = g'"
        using assms(1) is_full by (metis A.arrI A.ide_cod A.ide_dom A.in_homE)
      have "A.inverse_arrows f g"
        using assms 1 g g' A.inverse_arrowsI
        by (metis A.arr_iff_in_hom A.dom_comp A.in_homE A.seqI' B.inverse_arrowsE
            A.cod_comp locally_reflects_ide preserves_comp)
      thus ?thesis by auto
    qed

    lemma reflects_isomorphic:
    assumes "A.ide f" and "A.ide f'" and "B.isomorphic (F f) (F f')"
    shows "A.isomorphic f f'"
    proof -
      obtain ψ where ψ: "B.in_hom ψ (F f) (F f')  B.iso ψ"
        using assms B.isomorphic_def by auto
      obtain φ where φ: "A.in_hom φ f f'  F φ = ψ"
        using assms ψ is_full by blast
      have "A.iso φ"
        using φ ψ reflects_iso by auto
      thus ?thesis
        using φ A.isomorphic_def by auto
    qed

  end

  locale embedding_functor = "functor" A B F
  for A :: "'a comp"
  and B :: "'b comp"
  and F :: "'a  'b" +
  assumes is_embedding: " A.arr f; A.arr f'; F f = F f'   f = f'"

  sublocale embedding_functor  faithful_functor
    using is_embedding by (unfold_locales, blast)

  context embedding_functor
  begin

    lemma reflects_ide:
    assumes "B.ide (F f)"
    shows "A.ide f"
      using assms is_embedding A.ide_in_hom B.ide_in_hom
      by (metis A.in_homE B.in_homE A.ide_cod preserves_cod preserves_reflects_arr)

  end

  locale full_embedding_functor =
    embedding_functor A B F +
    full_functor A B F
  for A :: "'a comp"
  and B :: "'b comp"
  and F :: "'a  'b"

  locale essentially_surjective_functor = "functor" +
  assumes essentially_surjective: "b. B.ide b  a. A.ide a  B.isomorphic (F a) b"

  locale constant_functor =
    A: category A +
    B: category B
  for A :: "'a comp"
  and B :: "'b comp"
  and b :: 'b +
  assumes value_is_ide: "B.ide b"
  begin

    definition map
    where "map f = (if A.arr f then b else B.null)"

    lemma map_simp [simp]:
    assumes "A.arr f"
    shows "map f = b"
      using assms map_def by auto

    lemma is_functor:
    shows "functor A B map"
      using map_def value_is_ide by (unfold_locales, auto)
      
  end

  sublocale constant_functor  "functor" A B map
    using is_functor by auto

  locale identity_functor =
    C: category C
    for C :: "'a comp"
  begin

    definition map :: "'a  'a"
    where "map f = (if C.arr f then f else C.null)"

    lemma map_simp [simp]:
    assumes "C.arr f"
    shows "map f = f"
      using assms map_def by simp

    lemma is_functor:
    shows "functor C C map"
      using C.arr_dom_iff_arr C.arr_cod_iff_arr
      by (unfold_locales; auto simp add: map_def)

  end

  sublocale identity_functor  "functor" C C map
    using is_functor by auto

  text ‹
    It is convenient to have an easy way to obtain from a category the identity functor
    on that category. The following declaration causes the definitions and facts from the
    @{locale identity_functor} locale to be inherited by the @{locale category} locale,
    including the function @{term map} on arrows that represents the identity functor.
    This makes it generally unnecessary to give explicit interpretations of
    @{locale identity_functor}.
›

  sublocale category  identity_functor C ..

  text‹
    Composition of functors coincides with function composition, thanks to the
    magic of null›.
›

  lemma functor_comp:
  assumes "functor A B F" and "functor B C G"
  shows "functor A C (G o F)"
  proof -
    interpret F: "functor" A B F using assms(1) by auto
    interpret G: "functor" B C G using assms(2) by auto
    show "functor A C (G o F)"
      using F.preserves_arr F.is_extensional G.is_extensional by (unfold_locales, auto)
  qed

  locale composite_functor =
    F: "functor" A B F +
    G: "functor" B C G
  for A :: "'a comp"
  and B :: "'b comp"
  and C :: "'c comp"
  and F :: "'a  'b"
  and G :: "'b  'c"
  begin

    abbreviation map
    where "map  G o F"

  end

  sublocale composite_functor  "functor" A C G o F
    using functor_comp F.functor_axioms G.functor_axioms by blast

  lemma comp_functor_identity [simp]:
  assumes "functor A B F"
  shows "F o identity_functor.map A = F"
  proof
    interpret "functor" A B F using assms by blast
    show "x. (F o A.map) x = F x"
      using A.map_def is_extensional by simp
  qed

  lemma comp_identity_functor [simp]:
  assumes "functor A B F"
  shows "identity_functor.map B o F = F"
  proof
    interpret "functor" A B F using assms by blast
    show "x. (B.map o F) x = F x"
      using B.map_def by (metis comp_apply is_extensional preserves_arr)
  qed

  lemma faithful_functors_compose:
  assumes "faithful_functor A B F" and "faithful_functor B C G"
  shows "faithful_functor A C (G o F)"
  proof -
    interpret F: faithful_functor A B F
      using assms(1) by simp
    interpret G: faithful_functor B C G
      using assms(2) by simp
    interpret composite_functor A B C F G ..
    show "faithful_functor A C (G o F)"
    proof
      show "f f'. F.A.par f f'; map f = map f'  f = f'"
        using F.is_faithful G.is_faithful
        by (metis (mono_tags, lifting) F.preserves_arr F.preserves_cod F.preserves_dom o_apply)
    qed
  qed

  lemma full_functors_compose:
  assumes "full_functor A B F" and "full_functor B C G"
  shows "full_functor A C (G o F)"
  proof -
    interpret F: full_functor A B F
      using assms(1) by simp
    interpret G: full_functor B C G
      using assms(2) by simp
    interpret composite_functor A B C F G ..
    show "full_functor A C (G o F)"
    proof
      show "a a' g. F.A.ide a; F.A.ide a'; «g : map a'  map a»
                         f. F.A.in_hom f a' a  map f = g"
        using F.is_full G.is_full
        by (metis F.preserves_ide o_apply)
    qed
  qed

  lemma fully_faithful_functors_compose:
  assumes "fully_faithful_functor A B F" and "fully_faithful_functor B C G"
  shows "full_functor A C (G o F)"
  proof -
    interpret F: fully_faithful_functor A B F
      using assms(1) by simp
    interpret G: fully_faithful_functor B C G
      using assms(2) by simp
    interpret composite_functor A B C F G ..
    interpret faithful_functor A C G o F
      using F.faithful_functor_axioms G.faithful_functor_axioms faithful_functors_compose
      by blast
    interpret full_functor A C G o F
      using F.full_functor_axioms G.full_functor_axioms full_functors_compose
      by blast
    show "full_functor A C (G o F)" ..
  qed

  lemma embedding_functors_compose:
  assumes "embedding_functor A B F" and "embedding_functor B C G"
  shows "embedding_functor A C (G o F)"
  proof -
    interpret F: embedding_functor A B F
      using assms(1) by simp
    interpret G: embedding_functor B C G
      using assms(2) by simp
    interpret composite_functor A B C F G ..
    show "embedding_functor A C (G o F)"
    proof
      show "f f'. F.A.arr f; F.A.arr f'; map f = map f'  f = f'"
        by (simp add: F.is_embedding G.is_embedding)
    qed
  qed

  lemma full_embedding_functors_compose:
  assumes "full_embedding_functor A B F" and "full_embedding_functor B C G"
  shows "full_embedding_functor A C (G o F)"
  proof -
    interpret F: full_embedding_functor A B F
      using assms(1) by simp
    interpret G: full_embedding_functor B C G
      using assms(2) by simp
    interpret composite_functor A B C F G ..
    interpret embedding_functor A C G o F
      using F.embedding_functor_axioms G.embedding_functor_axioms embedding_functors_compose
      by blast
    interpret full_functor A C G o F
      using F.full_functor_axioms G.full_functor_axioms full_functors_compose
      by blast
    show "full_embedding_functor A C (G o F)" ..
  qed

  lemma essentially_surjective_functors_compose:
  assumes "essentially_surjective_functor A B F" and "essentially_surjective_functor B C G"
  shows "essentially_surjective_functor A C (G o F)"
  proof -
    interpret F: essentially_surjective_functor A B F
      using assms(1) by simp
    interpret G: essentially_surjective_functor B C G
      using assms(2) by simp
    interpret composite_functor A B C F G ..
    show "essentially_surjective_functor A C (G o F)"
    proof
      show "c. G.B.ide c  a. F.A.ide a  G.B.isomorphic (map a) c"
      proof -
        fix c
        assume c: "G.B.ide c"
        obtain b where b: "F.B.ide b  G.B.isomorphic (G b) c"
          using c G.essentially_surjective by auto
        obtain a where a: "F.A.ide a  F.B.isomorphic (F a) b"
          using b F.essentially_surjective by auto
        have "G.B.isomorphic (map a) c"
        proof -
          have "G.B.isomorphic (G (F a)) (G b)"
            using a G.preserves_iso G.B.isomorphic_def by blast
          thus ?thesis
            using b G.B.isomorphic_transitive by auto
        qed
        thus "a. F.A.ide a  G.B.isomorphic (map a) c"
          using a by auto
      qed
    qed
  qed

  locale inverse_functors =
    A: category A +
    B: category B +
    F: "functor" B A F +
    G: "functor" A B G
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and F :: "'b  'a"
  and G :: "'a  'b" +
  assumes inv: "G o F = identity_functor.map B"
  and inv': "F o G = identity_functor.map A"
  begin

    lemma bij_betw_arr_sets:
    shows "bij_betw F (Collect B.arr) (Collect A.arr)"
      using inv inv'
      apply (intro bij_betwI)
         apply auto
      using comp_eq_dest_lhs by force+

  end

  locale isomorphic_categories =
    A: category A +
    B: category B
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55) +
  assumes iso: "F G. inverse_functors A B F G"

  sublocale inverse_functors  isomorphic_categories A B
    using inverse_functors_axioms by (unfold_locales, auto)
  
  lemma inverse_functors_sym:
  assumes "inverse_functors A B F G"
  shows "inverse_functors B A G F"
  proof -
    interpret inverse_functors A B F G using assms by auto
    show ?thesis using inv inv' by (unfold_locales, auto)
  qed
  
  text ‹
    Inverse functors uniquely determine each other.
›

  lemma inverse_functor_unique:
  assumes "inverse_functors C D F G" and "inverse_functors C D F G'"
  shows "G = G'"
  proof -
    interpret FG: inverse_functors C D F G using assms(1) by auto
    interpret FG': inverse_functors C D F G' using assms(2) by auto
    show "G = G'"
      using FG.G.is_extensional FG'.G.is_extensional FG'.inv FG.inv'
      by (metis FG'.G.functor_axioms FG.G.functor_axioms comp_assoc comp_identity_functor
                comp_functor_identity)
  qed

  lemma inverse_functor_unique':
  assumes "inverse_functors C D F G" and "inverse_functors C D F' G"
  shows "F = F'"
    using assms inverse_functors_sym inverse_functor_unique by blast

  locale invertible_functor =
    A: category A +
    B: category B +
    G: "functor" A B G
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and G :: "'a  'b" +
  assumes invertible: "F. inverse_functors A B F G"
  begin

    lemma has_unique_inverse:
    shows "∃!F. inverse_functors A B F G"
      using invertible inverse_functor_unique' by blast

    definition inv
    where "inv  THE F. inverse_functors A B F G"

    interpretation inverse_functors A B inv G
      using inv_def has_unique_inverse theI' [of "λF. inverse_functors A B F G"]
      by simp

    lemma inv_is_inverse:
    shows "inverse_functors A B inv G" ..
  
    lemma preserves_terminal:
    assumes "A.terminal a"
    shows "B.terminal (G a)"
    proof
      show 0: "B.ide (G a)" using assms G.preserves_ide A.terminal_def by blast
      fix b :: 'b
      assume b: "B.ide b"
      show "∃!g. «g : b B G a»"
      proof
        let ?F = "SOME F. inverse_functors A B F G"
        from invertible have F: "inverse_functors A B ?F G"
          using someI_ex [of "λF. inverse_functors A B F G"] by fast
        interpret inverse_functors A B ?F G using F by auto
        let ?P = "λf. «f : ?F b A a»"
        have 1: "∃!f. ?P f" using assms b A.terminal_def by simp
        hence 2: "?P (THE f. ?P f)" by (metis (no_types, lifting) theI')
        thus "«G (THE f. ?P f) : b B G a»"
          using b apply (elim A.in_homE, intro B.in_homI, auto)
          using B.ideD(1) B.map_simp comp_def inv by metis
        hence 3: "«(THE f. ?P f) : ?F b A a»"
          using assms 2 b F by simp
        fix g :: 'b
        assume g: "«g : b B G a»"
        have "?F (G a) = a"
          using assms(1) A.terminal_def inv' A.map_simp
          by (metis 0 B.ideD(1) G.preserves_reflects_arr comp_eq_dest_lhs)
        hence "«?F g : ?F b A a»"
          using assms(1) g A.terminal_def inv
          by (elim B.in_homE, auto)
        hence "?F g = (THE f. ?P f)" using assms 1 3 A.terminal_def by blast
        thus "g = G (THE f. ?P f)"
          using inv g by (metis B.in_homE B.map_simp comp_def)
      qed
    qed
  
  end

  sublocale invertible_functor  inverse_functors A B inv G
    using inv_is_inverse by simp

  text ‹
    A bijection from a set S› to the set of arrows of a category C› induces an isomorphic
    copy of C› having S› as its set of arrows, assuming that there exists some n ∉ S›
    to serve as the null.
  ›

  context category
  begin

    lemma bij_induces_invertible_functor:
    assumes "bij_betw φ S (Collect arr)" and "n  S"
    shows "C'. Collect (partial_magma.arr C') = S 
                invertible_functor C' C (λi. if partial_magma.arr C' i then φ i else null)"
    proof -
      define ψ where "ψ = (λf. if arr f then inv_into S φ f else n)"
      have ψ: "bij_betw ψ (Collect arr) S"
        using assms(1) ψ_def bij_betw_inv_into
        by (metis (no_types, lifting) bij_betw_cong mem_Collect_eq)
      have φ_ψ [simp]: "f. arr f  φ (ψ f) = f"
        using assms(1) ψ ψ_def bij_betw_inv_into_right by fastforce
      have ψ_φ [simp]: "i. i  S  ψ (φ i) = i"
        unfolding ψ_def
        using assms(1) ψ bij_betw_inv_into_left [of φ S "Collect arr"]
        by (metis bij_betw_def image_eqI mem_Collect_eq)
      define C' where "C' = (λi j. if i  S  j  S  seq (φ i) (φ j) then ψ (φ i  φ j) else n)"
      interpret C': partial_magma C'
        using assms(1-2) C'_def ψ_def
        by unfold_locales metis
      have null_char: "C'.null = n"
        using assms(1-2) C'_def ψ_def C'.null_eqI by metis
      have ide_char: "i. C'.ide i  i  S  ide (φ i)"
      proof
        fix i
        assume i: "C'.ide i"
        show "i  S  ide (φ i)"
        proof (unfold ide_def, intro conjI)
          show 1: "φ i  φ i  null"
            using i assms(1) C'.ide_def C'_def null_char by auto
          show 2: "i  S"
            using 1 assms(1) by (metis C'.ide_def C'_def i)
          show "f. (f  φ i  null  f  φ i = f)  (φ i  f  null  φ i  f = f)"
          proof (intro allI conjI impI)
            show "f. f  φ i  null  f  φ i = f"
            proof -
              fix f
              assume f: "f  φ i  null"
              hence 1: "arr f  arr (φ i)  seq f (φ i)"
                by (meson seqE ext)
              have "f  φ i = φ (C' (ψ f) i)"
                using 1 2 C'_def null_char
                by (metis (no_types, lifting) φ_ψ ψ bij_betw_def image_eqI mem_Collect_eq)
              also have "... = f"
                by (metis 1 C'.ide_def C'_def φ_ψ ψ assms(2) bij_betw_def i image_eqI
                    mem_Collect_eq null_char)
              finally show "f  φ i = f" by simp
            qed
            show "f. φ i  f  null  φ i  f = f"
            proof -
              fix f
              assume f: "φ i  f  null"
              hence 1: "arr f  arr (φ i)  seq (φ i) f"
                by (meson seqE ext)
              show "φ i  f = f"
                using 1 2 C'_def null_char ψ
                by (metis (no_types, lifting) f. f  φ i  null  f  φ i = f
                    ide_char' codomains_null comp_cod_arr has_codomain_iff_arr
                    comp_ide_arr)
            qed
          qed
        qed
        next
        fix i
        assume i: "i  S  ide (φ i)"
        have "ψ (φ i)  S"
          using i assms(1)
          by (metis ψ bij_betw_def ideD(1) image_eqI mem_Collect_eq)
        show "C'.ide i"
          using assms(2) i C'_def null_char comp_arr_ide comp_ide_arr
          apply (unfold C'.ide_def, intro conjI allI impI)
            apply auto[1]
          by force+
      qed
      have dom: "i. i  S  ψ (dom (φ i))  C'.domains i"
      proof -
        fix i
        assume i: "i  S"
        have 1: "C'.ide (ψ (dom (φ i)))"
        proof (unfold C'.ide_def, intro conjI allI impI)
          show "C' (ψ (dom (φ i))) (ψ (dom (φ i)))  C'.null"
          proof -
            have "C' (ψ (dom (φ i))) (ψ (dom (φ i))) = ψ (dom (φ i))"
              using C'_def i assms(1-2) ψ ψ_φ ψ_def bij_betw_def
              by (metis (no_types, lifting) C'.ide_def φ_ψ ide_char ide_dom image_eqI
                  mem_Collect_eq)
            moreover have "ψ (dom (φ i))  C'.null"
              using i null_char assms(1-2) bij_betw_def
              by (metis ψ arr_dom_iff_arr image_iff mem_Collect_eq)
            ultimately show ?thesis
              by simp
          qed
          show "j. C' j (ψ (dom (φ i)))  C'.null  C' j (ψ (dom (φ i))) = j"
          proof -
            fix j
            assume j: "C' j (ψ (dom (φ i)))  C'.null"
            show "C' j (ψ (dom (φ i))) = j"
              using j φ_ψ ψ_def ide_char null_char
              by (metis C'.comp_null(2) C'.ide_def C'_def
                  C' (ψ (dom (φ i))) (ψ (dom (φ i)))  C'.null›
                  arr_dom_iff_arr ide_dom)
          qed
          show "j. C' (ψ (dom (φ i))) j  C'.null  C' (ψ (dom (φ i))) j = j"
          proof -
            fix j
            assume j: "C' (ψ (dom (φ i))) j  C'.null"
            show "C' (ψ (dom (φ i))) j = j"
              using j
              by (metis C'.ide_def C'_def
                  C' (ψ (dom (φ i))) (ψ (dom (φ i)))  C'.null›
                  j. C' j (ψ (dom (φ i)))  C'.null  C' j (ψ (dom (φ i))) = j
                  φ_ψ ψ_def arr_dom_iff_arr ide_char ide_dom null_char)
          qed
        qed
        moreover have "C' i (ψ (dom (φ i)))  C'.null"
          using i 1 assms(1-2) C'_def null_char ide_char φ_ψ ψ_φ ψ_def comp_arr_dom
          apply simp
          by (metis (no_types, lifting))
        ultimately show "ψ (dom (φ i))  C'.domains i"
          using C'.domains_def by simp
      qed
      have cod: "i. i  S  ψ (cod (φ i))  C'.codomains i"
      proof -
        fix i
        assume i: "i  S"
        have 1: "C'.ide (ψ (cod (φ i)))"
        proof (unfold C'.ide_def, intro conjI allI impI)
          show "C' (ψ (cod (φ i))) (ψ (cod (φ i)))  C'.null"
          proof -
            have "C' (ψ (cod (φ i))) (ψ (cod (φ i))) = ψ (cod (φ i))"
            proof -
              have "φ (ψ (cod (φ i))) = cod (φ i)"
                using i assms(1-2) φ_ψ ψ_φ ψ_def arr_cod_iff_arr by force
              moreover have "cod (φ i)  cod (φ i) = cod (φ i)"
                using i assms(1-2) comp_ide_self ide_cod [of "φ i"] ψ_φ ψ_def by fastforce
              ultimately show ?thesis
                using C'_def i assms(1)
                apply simp
                by (metis (no_types, lifting) ψ ψ_def bij_betw_def image_eqI mem_Collect_eq)
            qed
            moreover have "ψ (cod (φ i))  C'.null"
              using i null_char assms(1-2)
              by (metis ψ bij_betw_def category.arr_cod_iff_arr category_axioms
                  image_eqI mem_Collect_eq)
            ultimately show ?thesis
              by simp
          qed
          show "j. C' (ψ (cod (φ i))) j  C'.null  C' (ψ (cod (φ i))) j = j"
          proof -
            fix j
            assume j: "C' (ψ (cod (φ i))) j  C'.null"
            show "C' (ψ (cod (φ i))) j = j"
              using j
              by (metis C'.comp_null(2) C'.ide_def C'_def
                  C' (ψ (cod (φ i))) (ψ (cod (φ i)))  C'.null›
                  φ_ψ ψ_def arr_cod_iff_arr category.ide_cod category_axioms ide_char null_char)
          qed
          show "j. C' j (ψ (cod (φ i)))  C'.null  C' j (ψ (cod (φ i))) = j"
          proof -
            fix j
            assume j: "C' j (ψ (cod (φ i)))  C'.null"
            show "C' j (ψ (cod (φ i))) = j"
              using j
              by (metis C'.ide_def C'_def C' (ψ (cod (φ i))) (ψ (cod (φ i)))  C'.null›
                  j. C' (ψ (cod (φ i))) j  C'.null  C' (ψ (cod (φ i))) j = j
                  φ_ψ ψ_def arr_cod_iff_arr category.ide_cod category_axioms ide_char null_char)
          qed
        qed
        moreover have "C' (ψ (cod (φ i))) i  C'.null"
          using i assms(1-2) C'_def null_char φ_ψ ψ_φ ψ_def comp_cod_arr ide_char
          apply simp
          by (metis (no_types, lifting) ψ_def 1)
        ultimately show "ψ (cod (φ i))  C'.codomains i"
          using C'.codomains_def by simp
      qed
      have arr_char: "i. C'.arr i  i  S"
      proof
        fix i
        show "i  S  C'.arr i"
          using dom cod C'.arr_def by auto
        show "C'.arr i  i  S"
          using C'_def C'.arr_def C'.domains_def C'.codomains_def null_char
          apply simp
          by metis
      qed
      have seq_char: "i j. C'.seq i j  i  S  j  S  seq (φ i) (φ j)"
        using assms(1-2) C'_def arr_char null_char
        apply simp
        using ψ bij_betw_apply by fastforce
      interpret C': category C'
      proof
        show "g f. C' g f  C'.null  C'.seq g f"
          using C'_def null_char seq_char by fastforce
        show "f. (C'.domains f  {}) = (C'.codomains f  {})"
          using dom cod null_char arr_char C'.arr_def by blast
        show "h g f. C'.seq h g; C'.seq (C' h g) f  C'.seq g f"
          using seq_char
          apply simp
          using C'_def by fastforce
        show "h g f. C'.seq h (C' g f); C'.seq g f  C'.seq h g"
          using seq_char
          apply simp
          using C'_def by fastforce
        show "g f h. C'.seq g f; C'.seq h g  C'.seq (C' h g) f"
          using seq_char arr_char
          apply simp
          using C'_def by auto
        show "g f h. C'.seq g f; C'.seq h g  C' (C' h g) f = C' h (C' g f)"
          using seq_char arr_char C'_def comp_assoc assms(2)
          apply simp by presburger
      qed
      have dom_char: "C'.dom = (λi. if i  S then ψ (dom (φ i)) else n)"
        using dom arr_char null_char C'.dom_eqI' C'.arr_def C'.dom_def by metis
      have cod_char: "C'.cod = (λi. if i  S then ψ (cod (φ i)) else n)"
        using cod arr_char null_char C'.cod_eqI' C'.arr_def C'.cod_def by metis
      interpret φ: "functor" C' C λi. if C'.arr i then φ i else null›
        using arr_char null_char dom_char cod_char seq_char φ_ψ ψ_φ ψ_def C'.not_arr_null C'_def
              C'.arr_dom C'.arr_cod
        apply unfold_locales
            apply simp_all
           apply (metis (full_types))
          apply force
         apply force
        by metis
      interpret ψ: "functor" C C' ψ
        using ψ_def null_char arr_char
        apply unfold_locales
            apply simp
           apply (metis (no_types, lifting) ψ bij_betw_def image_eqI mem_Collect_eq)
          apply (metis (no_types, lifting) φ_ψ ψ bij_betw_def dom_char image_eqI mem_Collect_eq)
         apply (metis (no_types, lifting) φ_ψ ψ bij_betw_def cod_char image_eqI mem_Collect_eq)
        by (metis (no_types, lifting) C'_def φ_ψ ψ bij_betw_def seqE image_eqI mem_Collect_eq)
      interpret φψ: inverse_functors C' C ψ λi. if C'.arr i then φ i else null›
      proof
        show "ψ  (λi. if C'.arr i then φ i else null) = C'.map"
          by (auto simp add: C'.is_extensional ψ.is_extensional arr_char)
        show "(λi. if C'.arr i then φ i else null)  ψ = map"
          by (auto simp add: is_extensional)
      qed
      have "invertible_functor C' C (λi. if C'.arr i then φ i else null)"
        using φψ.inverse_functors_axioms by unfold_locales auto
      thus ?thesis
        using arr_char by blast
    qed

    corollary (in category) finite_imp_ex_iso_nat_comp:
    assumes "finite (Collect arr)"
    shows "C' :: nat comp. isomorphic_categories C' C"
    proof -
      obtain n :: nat and φ where φ: "bij_betw φ {0..<n} (Collect arr)"
        using assms ex_bij_betw_nat_finite by blast
      obtain C' where C': "Collect (partial_magma.arr C') = {0..<n} 
                           invertible_functor C' (⋅)
                             (λi. if partial_magma.arr C' i then φ i else null)"
        using φ bij_induces_invertible_functor [of φ "{0..<n}"] by auto
      interpret φ: invertible_functor C' C λi. if partial_magma.arr C' i then φ i else null›
        using C' by simp
      show ?thesis
        using φ.isomorphic_categories_axioms by blast
    qed

  end

  text ‹
    We now prove the result, advertised earlier in theory ConcreteCategory›,
    that any category is in fact isomorphic to the concrete category formed from it in
    the obvious way.
  ›

  context category
  begin

    interpretation CC: concrete_category ‹Collect ide› hom id λC B A g f. g  f
      using comp_arr_dom comp_cod_arr comp_assoc
      by (unfold_locales, auto)

    interpretation F: "functor" C CC.COMP
                       λf. if arr f then CC.MkArr (dom f) (cod f) f else CC.null›
      by (unfold_locales, auto simp add: in_homI)

    interpretation G: "functor" CC.COMP C λF. if CC.arr F then CC.Map F else null›
      using CC.Map_in_Hom CC.seq_char
      by (unfold_locales, auto)

    interpretation FG: inverse_functors C CC.COMP
                       λF. if CC.arr F then CC.Map F else null›
                       λf. if arr f then CC.MkArr (dom f) (cod f) f else CC.null›
    proof
      show "(λF. if CC.arr F then CC.Map F else null) 
              (λf. if arr f then CC.MkArr (dom f) (cod f) f else CC.null) =
            map"
        using CC.arr_char map_def by fastforce
      show "(λf. if arr f then CC.MkArr (dom f) (cod f) f else CC.null) 
              (λF. if CC.arr F then CC.Map F else null) =
            CC.map"
        using CC.MkArr_Map G.preserves_arr G.preserves_cod G.preserves_dom
              CC.is_extensional
        by auto
    qed

    interpretation isomorphic_categories C CC.COMP ..

    theorem is_isomorphic_to_concrete_category:
    shows "isomorphic_categories C CC.COMP"
      ..

  end

  locale dual_functor =
    F: "functor" A B F +
    Aop: dual_category A +
    Bop: dual_category B
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and F :: "'a  'b"
  begin

    notation Aop.comp     (infixr "Aop" 55)
    notation Bop.comp     (infixr "Bop" 55)

    definition map
    where "map  F"

    lemma map_simp [simp]:
    shows "map f = F f"
      by (simp add: map_def)

    lemma is_functor:
    shows "functor Aop.comp Bop.comp map"
      using F.is_extensional by (unfold_locales, auto)

  end

  sublocale invertible_functor  inverse_functors A B inv G
    using inv_is_inverse by simp

   sublocale dual_functor  "functor" Aop.comp Bop.comp map
    using is_functor by auto

end

Theory SetCategory

(*  Title:       SetCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter SetCategory

theory SetCategory
imports Category Functor "HOL-Cardinals.Cardinals"
begin

  text‹
    This theory defines a locale set_category› that axiomatizes the notion
    ``category of @{typ 'a}-sets and functions between them'' in the context of HOL.
    A primary reason for doing this is to make it possible to prove results
    (such as the Yoneda Lemma) that use such categories without having to commit to a
    particular element type @{typ 'a} and without having the results depend on the
    concrete details of a particular construction.
    The axiomatization given here is categorical, in the sense that if categories
    @{term S} and @{term S'} each interpret the set_category› locale,
    then a bijection between the sets of terminal objects of @{term S} and @{term S'}
    extends to an isomorphism of @{term S} and @{term S'} as categories.

    The axiomatization is based on the following idea: if, for some type @{typ 'a},
    category @{term S} is the category of all @{typ 'a}-sets and functions between
    them, then the elements of type @{typ 'a} are in bijective correspondence with
    the terminal objects of category @{term S}.  In addition, if @{term unity}
    is an arbitrarily chosen terminal object of @{term S}, then for each object @{term a},
    the hom-set @{term "hom unity a"} (\emph{i.e.} the set of ``points'' or
    ``global elements'' of @{term a}) is in bijective correspondence with a subset
    of the terminal objects of @{term S}.  By making a specific, but arbitrary,
    choice of such a correspondence, we can then associate with each object @{term a}
    of @{term S} a set @{term "set a"} that consists of all terminal objects @{term t}
    that correspond to some point @{term x} of @{term a}.  Each arrow @{term f}
    then induces a function Fun f ∈ set (dom f) → set (cod f)›,
    defined on terminal objects of @{term S} by passing to points of @{term "dom f"},
    composing with @{term f}, then passing back from points of @{term "cod f"}
    to terminal objects.  Once we can associate a set with each object of @{term S}
    and a function with each arrow, we can force @{term S} to be isomorphic to the
    category of @{typ 'a}-sets by imposing suitable extensionality and completeness axioms.
›
 
  section "Some Lemmas about Restriction"

    text‹
      \sloppypar
      The development of the set_category› locale makes heavy use of the
      theory @{theory "HOL-Library.FuncSet"}.  However, in some cases, I found that
      that theory did not provide results about restriction in the form that was
      most useful to me. I used the following additional results in various places.
›

  (* This variant of FuncSet.restrict_ext is sometimes useful. *)

  lemma restr_eqI:
  assumes "A = A'" and "x. x  A  F x = F' x"
  shows "restrict F A = restrict F' A'"
    using assms by force

  (* This rule avoided a long proof in at least one instance
     where FuncSet.restrict_apply did not work.
   *)
  lemma restr_eqE [elim]:
  assumes "restrict F A = restrict F' A" and "x  A"
  shows "F x = F' x"
    using assms restrict_def by metis

  (* This seems more useful than compose_eq in FuncSet. *)
  lemma compose_eq' [simp]:
  shows "compose A G F = restrict (G o F) A"
    unfolding compose_def restrict_def by auto

  section "Set Categories"

  text‹
    We first define the locale set_category_data›, which sets out the basic
    data and definitions for the set_category› locale, without imposing any conditions
    other than that @{term S} is a category and that @{term img} is a function defined
    on the arrow type of @{term S}.  The function @{term img} should be thought of
    as a mapping that takes a point @{term "x  hom unity a"} to a corresponding
    terminal object @{term "img x"}.  Eventually, assumptions will be introduced so
    that this is in fact the case.
›

  locale set_category_data = category S
  for S :: "'s comp"      (infixr "" 55)
  and img :: "'s  's"
  begin

    notation in_hom       ("«_ : _  _»")

    text‹
      Call the set of all terminal objects of S the ``universe''.
›
    abbreviation Univ :: "'s set"
    where "Univ  Collect terminal"
  
    text‹
      Choose an arbitrary element of the universe and call it @{term unity}.
›
    definition unity :: 's
    where "unity = (SOME t. terminal t)"
    
    text‹
      Each object @{term a} determines a subset @{term "set a"} of the universe,
      consisting of all those terminal objects @{term t} such that @{term "t = img x"}
      for some @{term "x  hom unity a"}.
›
    definition set :: "'s  's set"
    where "set a = img ` hom unity a"

  end

  text‹
    Next, we define a locale set_category_given_img› that augments the
    set_category_data› locale with assumptions that serve to define
    the notion of a set category with a chosen correspondence between points
    and terminal objects.  The assumptions require that the universe be nonempty
    (so that the definition of @{term unity} makes sense), that the map
    @{term img} is a locally injective map taking points to terminal objects,
    that each terminal object @{term t} belongs to @{term "set t"},
    that two objects of @{term S} are equal if they determine the same set,
    that two parallel arrows of @{term S} are equal if they determine the same
    function, that there is an object corresponding to each subset of the universe
    whose cardinality is less than a specified cardinal 𝔄›, and that for any objects
    @{term a} and @{term b} and function @{term "F  hom unity a  hom unity b"}
    there is an arrow @{term "f  hom a b"} whose action under the composition
    of @{term S} coincides with the function @{term F}.

    The cardinal 𝔄›, which is given as a parameter to the locale, has been introduced
    because most of the familiar properties of a set category do not depend on
    there being an object corresponding to \emph{every} subset of the universe,
    and we would like to consider such situations; for example, the situation in
    which there only \emph{finite} subsets determine objects.
›
    
  locale set_category_given_img = set_category_data S img
  for S :: "'s comp"      (infixr "" 55)
  and img :: "'s  's"
  and 𝔄 :: "'t rel" +
  assumes nonempty_Univ: "Univ  {}"
  and img_mapsto: "ide a  img  hom unity a  Univ"
  and card_points: "ide a  |hom unity a| <o 𝔄"
  and inj_img: "ide a  inj_on img (hom unity a)"
  and stable_img: "terminal t  t  img ` hom unity t"
  and extensional_set: " ide a; ide b; set a = set b   a = b"
  and extensional_arr: " par f f'; x. «x : unity  dom f»  f  x = f'  x   f = f'"
  and set_complete: " A  Univ; |A| <o 𝔄   a. ide a  set a = A"
  and fun_complete1: " ide a; ide b; F  hom unity a  hom unity b 
                           f. «f : a  b»  (x. «x : unity  dom f»  f  x = F x)"
  and cardinal: "Card_order 𝔄  infinite (Field 𝔄)"
  begin

    text‹
      The inverse of the map @{term set} is a map @{term mkIde} that takes each subset
      of the universe of cardinality less than 𝔄› to an identity of @{term[source=true] S}.
›
    definition mkIde :: "'s set  's"
    where "mkIde A = (if A  Univ  |A| <o 𝔄 then inv_into (Collect ide) set A else null)"

    text‹
      Each arrow @{term "f  hom a b"} determines a function @{term "Fun f  Univ  Univ"},
      by passing from @{term Univ} to @{term "hom a unity"}, composing with @{term f},
      then passing back to @{term Univ}.
›

    definition Fun :: "'s  's  's"
    where "Fun f = restrict (img o S f o inv_into (hom unity (dom f)) img) (set (dom f))"

    lemma comp_arr_point:
    assumes "arr f" and "«x : unity  dom f»"
    shows "f  x = inv_into (hom unity (cod f)) img (Fun f (img x))"
    proof -
      have "«f  x : unity  cod f»"
        using assms by blast
      thus ?thesis
        using assms Fun_def inj_img set_def by simp
    qed
      
    text‹
      Parallel arrows that determine the same function are equal.
›

    lemma arr_eqI:
    assumes "par f f'" and "Fun f = Fun f'"
    shows "f = f'"
      using assms comp_arr_point extensional_arr by metis

    lemma terminal_unity:
    shows "terminal unity"
      using unity_def nonempty_Univ by (simp add: someI_ex)

    lemma ide_unity [simp]:
    shows "ide unity"
      using terminal_unity terminal_def by blast

    lemma set_subset_Univ [simp]:
    assumes "ide a"
    shows "set a  Univ"
      using assms set_def img_mapsto by auto
  
    lemma inj_on_set:
    shows "inj_on set (Collect ide)"
      using extensional_set by (intro inj_onI, auto)
      
    text‹
      The mapping @{term mkIde}, which takes subsets of the universe to identities,
      and @{term set}, which takes identities to subsets of the universe, are inverses.
›

    lemma set_card:
    assumes "ide a"
    shows "|set a| <o 𝔄"
      using assms card_points set_def
      by (metis card_of_image ordLeq_ordLess_trans)

    lemma mkIde_set [simp]:
    assumes "ide a"
    shows "mkIde (set a) = a"
      using assms mkIde_def inj_on_set inv_into_f_f set_card
      by (simp add: ordLess_imp_ordLeq)

    lemma set_mkIde:
    assumes "A  Univ" and "|A| <o 𝔄"
    shows "set (mkIde A) = A"
      using assms mkIde_def set_complete someI_ex [of "λa. a  Collect ide  set a = A"]
      by (metis set_category_given_img.mkIde_set set_category_given_img_axioms)
      
    lemma ide_mkIde:
    assumes "A  Univ" and "|A| <o 𝔄"
    shows "ide (mkIde A)"
      using assms mkIde_def mkIde_set set_complete by metis

    text‹
      Because we have assumed the cardinal 𝔄› to be infinite, there is an object corresponding
      to every finite subset of the universe.
    ›

    lemma ide_mkIde_finite:
    assumes "A  Univ" and "finite A"
    shows "ide (mkIde A)"
    proof -
      have "|A| <o 𝔄"
      proof -
        have "finite (Field |A| )"
          using assms(2) by simp
        thus ?thesis
          using cardinal card_of_Well_order card_order_on_def finite_ordLess_infinite
          by blast
        qed
        thus ?thesis
          using assms(1) ide_mkIde [of A] by simp
    qed

    lemma arr_mkIde:
    shows "arr (mkIde A)  A  Univ  |A| <o 𝔄"
      using ide_mkIde mkIde_def not_arr_null by force
    
    lemma dom_mkIde:
    assumes "A  Univ" and "|A| <o 𝔄"
    shows "dom (mkIde A) = mkIde A"
      using assms ide_mkIde by simp
    
    lemma cod_mkIde:
    assumes "A  Univ" and "|A| <o 𝔄"
    shows "cod (mkIde A) = mkIde A"
      using assms ide_mkIde by simp
      
    text‹
      Each arrow @{term f} determines an extensional function from
      @{term "set (dom f)"} to @{term "set (cod f)"}.
›

    lemma Fun_mapsto:
    assumes "arr f"
    shows "Fun f  extensional (set (dom f))  (set (dom f)  set (cod f))"
    proof
      show "Fun f  extensional (set (dom f))" using Fun_def by fastforce
      show "Fun f  set (dom f)  set (cod f)"
      proof
        fix t
        assume t: "t  set (dom f)"
        have "Fun f t = img (f  inv_into (hom unity (dom f)) img t)"
          using assms t Fun_def comp_def by simp
        moreover have "...  set (cod f)"
          using assms t set_def inv_into_into [of t img "hom unity (dom f)"] by blast
        ultimately show "Fun f t  set (cod f)" by auto
      qed
    qed
    
    text‹
      Identities of @{term[source=true] S} correspond to restrictions of the identity function.
›

    lemma Fun_ide:
    assumes "ide a"
    shows "Fun a = restrict (λx. x) (set a)"
      using assms Fun_def inj_img set_def comp_cod_arr by fastforce
    
    lemma Fun_mkIde:
    assumes "A  Univ" and "|A| <o 𝔄"
    shows "Fun (mkIde A) = restrict (λx. x) A"
      using assms ide_mkIde set_mkIde Fun_ide by simp
    
    text‹
      Composition in @{term S} corresponds to extensional function composition.
›

    lemma Fun_comp [simp]:
    assumes "seq g f"
    shows "Fun (g  f) = restrict (Fun g o Fun f) (set (dom f))"
    proof -
      have "restrict (img o S (g  f) o (inv_into (hom unity (dom (g  f))) img))
                     (set (dom (g  f)))
              = restrict (Fun g o Fun f) (set (dom f))"
      proof -
        have 1: "set (dom (g  f)) = set (dom f)"
          using assms by auto
        let ?img' = "λa. λt. inv_into (hom unity a) img t"
        have 2: "t. t  set (dom (g  f)) 
                     (img o S (g  f) o ?img' (dom (g  f))) t = (Fun g o Fun f) t"
        proof -
          fix t
          assume "t  set (dom (g  f))"
          hence t: "t  set (dom f)" by (simp add: 1)
          have 3: "a x. x  hom unity a  ?img' a (img x) = x"
            using assms inj_img ide_cod inv_into_f_eq
            by (metis arrI in_homE mem_Collect_eq)
          have 4: "?img' (dom f) t  hom unity (dom f)"
            using assms t inv_into_into [of t img "hom unity (dom f)"] set_def by simp
          have "(img o S (g  f) o ?img' (dom (g  f))) t = img (g  f  ?img' (dom f) t)"
            using assms dom_comp comp_assoc by simp
          also have "... = img (g  ?img' (dom g) (Fun f t))"
            using assms t 3 Fun_def set_def comp_arr_point by auto
          also have "... = Fun g (Fun f t)"
          proof -
            have "Fun f t  img ` hom unity (cod f)"
              using assms t Fun_mapsto set_def by fast
            thus ?thesis using assms by (auto simp add: set_def Fun_def)
          qed
          finally show "(img o S (g  f) o ?img' (dom (g  f))) t = (Fun g o Fun f) t"
            by auto
        qed
        show ?thesis using 1 2 by auto
      qed
      thus ?thesis using Fun_def by auto
    qed

    text‹
      The constructor @{term mkArr} is used to obtain an arrow given subsets
      @{term A} and @{term B} of the universe and a function @{term "F  A  B"}.
›
    
    definition mkArr :: "'s set  's set  ('s  's)  's"
    where "mkArr A B F = (if A  Univ  |A| <o 𝔄  B  Univ  |B| <o 𝔄  F  A  B
                          then (THE f. f  hom (mkIde A) (mkIde B)  Fun f = restrict F A)
                          else null)"

    text‹
      Each function @{term "F  set a  set b"} determines a unique arrow @{term "f  hom a b"},
      such that @{term "Fun f"} is the restriction of @{term F} to @{term "set a"}.
›

    lemma fun_complete:
    assumes "ide a" and "ide b" and "F  set a  set b"
    shows "∃!f. «f : a  b»  Fun f = restrict F (set a)"
    proof -
      let ?P = "λf. «f : a  b»  Fun f = restrict F (set a)"
      show "∃!f. ?P f"
      proof
        have "f. ?P f"
        proof -
          let ?F' = "λx. inv_into (hom unity b) img (F (img x))"
          have "?F'  hom unity a  hom unity b"
          proof
            fix x
            assume x: "x  hom unity a"
            have "F (img x)  set b" using assms(3) x set_def by auto
            thus "inv_into (hom unity b) img (F (img x))  hom unity b"
              using assms inj_img set_def by auto
          qed
          hence "f. «f : a  b»  (x. «x : unity  a»  f  x = ?F' x)"
            using assms fun_complete1 [of a b] by force
          from this obtain f where f: "«f : a  b»  (x. «x : unity  a»  f  x = ?F' x)"
            by blast
          let ?img' = "λa. λt. inv_into (hom unity a) img t"
          have "Fun f = restrict F (set a)"
          proof (unfold Fun_def, intro restr_eqI)
            show "set (dom f) = set a" using f by auto
            show "t. t  set (dom f)  (img  S f  ?img' (dom f)) t = F t"
            proof -
              fix t
              assume t: "t  set (dom f)"
              have "(img  S f  ?img' (dom f)) t = img (f  ?img' (dom f) t)"
                by simp
              also have "... = img (?F' (?img' (dom f) t))"
              proof -
                have "?img' (dom f) t  hom unity (dom f)"
                  using t set_def inv_into_into by metis
                thus ?thesis using f by auto
              qed
              also have "... = img (?img' (cod f) (F t))"
                using f t set_def inj_img by auto
              also have "... = F t"
              proof -
                have "F t  set (cod f)"
                  using assms f t by auto
                thus ?thesis
                  using f t set_def inj_img by auto
              qed
              finally show "(img  S f  ?img' (dom f)) t = F t" by auto
            qed
          qed
          thus ?thesis using f by blast
        qed
        thus F: "?P (SOME f. ?P f)" using someI_ex [of ?P] by fast
        show "f'. ?P f'  f' = (SOME f. ?P f)"
          using F arr_eqI
          by (metis (no_types, lifting) in_homE)
      qed
    qed
                          
    lemma mkArr_in_hom:
    assumes "A  Univ" and "|A| <o 𝔄" and "B  Univ" and "|B| <o 𝔄" and "F  A  B"
    shows "«mkArr A B F : mkIde A  mkIde B»"
      using assms mkArr_def fun_complete [of "mkIde A" "mkIde B" F] ide_mkIde set_mkIde
            theI' [of "λf. f  hom (mkIde A) (mkIde B)  Fun f = restrict F A"]
      by simp

    text‹
      The ``only if'' direction of the next lemma can be achieved only if there exists a
      non-arrow element of type @{typ 's}, which can be used as the value of @{term "mkArr A B F"}
      in cases where @{term "F  A  B"}.  Nevertheless, it is essential to have this,
      because without the ``only if'' direction, we can't derive any useful
      consequences from an assumption of the form @{term "arr (mkArr A B F)"};
      instead we have to obtain @{term "F  A  B"} some other way.
      This is is usually highly inconvenient and it makes the theory very weak and almost
      unusable in practice.  The observation that having a non-arrow value of type @{typ 's}
      solves this problem is ultimately what led me to incorporate @{term null} first into the
      definition of the set_category› locale and then, ultimately, into the definition
      of the category› locale.  I believe this idea is critical to the usability of the
      entire development.
›

    (* TODO: This gets used as an introduction rule, but the conjunction on the right-hand side
       is not very convenient. *)
    lemma arr_mkArr:
    shows "arr (mkArr A B F) 
           A  Univ  |A| <o 𝔄  B  Univ  |B| <o 𝔄  F  A  B"
    proof
      show "arr (mkArr A B F) 
              A  Univ  |A| <o 𝔄  B  Univ  |B| <o 𝔄  F  A  B"
        using mkArr_def domains_null codomains_null has_domain_iff_arr has_codomain_iff_arr
              not_arr_null
        by (intro conjI) metis+
      show "A  Univ  |A| <o 𝔄  B  Univ  |B| <o 𝔄  F  A  B
                arr (mkArr A B F)"
        using mkArr_in_hom by auto
    qed
    
    lemma Fun_mkArr':
    assumes "arr (mkArr A B F)"
    shows "«mkArr A B F : mkIde A  mkIde B»"
    and "Fun (mkArr A B F) = restrict F A"
    proof -
      have 1: "A  Univ  |A| <o 𝔄  B  Univ  |B| <o 𝔄  F  A  B"
        using assms arr_mkArr by simp
      have 2: "mkArr A B F  hom (mkIde A) (mkIde B) 
                     Fun (mkArr A B F) = restrict F (set (mkIde A))"
      proof -
        have "∃!f. f  hom (mkIde A) (mkIde B)  Fun f = restrict F (set (mkIde A))"
          using 1 fun_complete [of "mkIde A" "mkIde B" F] ide_mkIde set_mkIde by simp
        thus ?thesis using 1 mkArr_def theI' set_mkIde by simp
      qed
      show "«mkArr A B F : mkIde A  mkIde B»" using 1 2 by auto
      show "Fun (mkArr A B F) = restrict F A" using 1 2 set_mkIde by auto
    qed

    lemma mkArr_Fun:
    assumes "arr f"
    shows "mkArr (set (dom f)) (set (cod f)) (Fun f) = f"
    proof -
      have 1: "set (dom f)  Univ  |set (dom f)| <o 𝔄 
               set (cod f)  Univ  |set (cod f)| <o 𝔄 
               ide (dom f)  ide (cod f) 
               Fun f  extensional (set (dom f))  (set (dom f)  set (cod f))"
        using assms Fun_mapsto set_def set_card set_subset_Univ by auto
      hence "∃!f'. f'  hom (dom f) (cod f)  Fun f' = restrict (Fun f) (set (dom f))"
        using fun_complete by force
      moreover have "f  hom (dom f) (cod f)  Fun f = restrict (Fun f) (set (dom f))"
        using assms 1 extensional_restrict by force
      ultimately have "f = (THE f'. f'  hom (dom f) (cod f) 
                                    Fun f' = restrict (Fun f) (set (dom f)))"
        using theI' [of "λf'. f'  hom (dom f) (cod f)  Fun f' = restrict (Fun f) (set (dom f))"]
        by blast
      also have "... = mkArr (set (dom f)) (set (cod f)) (Fun f)"
        using assms 1 mkArr_def mkIde_set by simp
      finally show ?thesis by auto
    qed
    
    lemma dom_mkArr [simp]:
    assumes "arr (mkArr A B F)"
    shows "dom (mkArr A B F) = mkIde A"
      using assms Fun_mkArr' by auto
        
    lemma cod_mkArr [simp]:
    assumes "arr (mkArr A B F)"
    shows "cod (mkArr A B F) = mkIde B"
      using assms Fun_mkArr' by auto
     
    lemma Fun_mkArr [simp]:
    assumes "arr (mkArr A B F)"
    shows "Fun (mkArr A B F) = restrict F A"
      using assms Fun_mkArr' by auto

    text‹
      The following provides the basic technique for showing that arrows
      constructed using @{term mkArr} are equal.
›

    lemma mkArr_eqI [intro]:
    assumes "arr (mkArr A B F)"
    and "A = A'" and "B = B'" and "x. x  A  F x = F' x"
    shows "mkArr A B F = mkArr A' B' F'"
      using assms arr_mkArr Fun_mkArr
      by (intro arr_eqI, auto simp add: Pi_iff)

    text‹
      This version avoids trivial proof obligations when the domain and codomain
      sets are identical from the context.
›
    
    lemma mkArr_eqI' [intro]:
    assumes "arr (mkArr A B F)" and "x. x  A  F x = F' x"
    shows "mkArr A B F = mkArr A B F'"
      using assms mkArr_eqI arr_mkArr by simp
    
    lemma mkArr_restrict_eq:
    assumes "arr (mkArr A B F)"
    shows "mkArr A B (restrict F A) = mkArr A B F"
      using assms arr_mkArr by (intro mkArr_eqI', auto)
      
    lemma mkArr_restrict_eq':
    assumes "arr (mkArr A B (restrict F A))"
    shows "mkArr A B (restrict F A) = mkArr A B F"
      using assms by (intro mkArr_eqI', auto)
      
    lemma mkIde_as_mkArr:
    assumes "A  Univ" and "|A| <o 𝔄"
    shows "mkArr A A (λx. x) = mkIde A"
      using assms arr_mkIde arr_mkArr dom_mkIde cod_mkIde Fun_mkIde
      by (intro arr_eqI, auto)

    lemma comp_mkArr:
    assumes "arr (mkArr A B F)" and "arr (mkArr B C G)"
    shows "mkArr B C G  mkArr A B F = mkArr A C (G  F)"
    proof (intro arr_eqI)
      have 1: "seq (mkArr B C G) (mkArr A B F)" using assms by force
      have 2: "G o F  A  C" using assms arr_mkArr by auto
      show "par (mkArr B C G  mkArr A B F) (mkArr A C (G  F))"
        using assms 1 2 arr_mkArr
        by (intro conjI) simp_all
      show "Fun (mkArr B C G  mkArr A B F) = Fun (mkArr A C (G  F))"
        using 1 2 arr_mkArr set_mkIde by fastforce
    qed
    
    text‹
      The locale assumption @{prop stable_img} forces @{term "t  set t"} in case
      @{term t} is a terminal object.  This is very convenient, as it results in the
      characterization of terminal objects as identities @{term t} for which
      @{term "set t = {t}"}.  However, it is not absolutely necessary to have this.
      The following weaker characterization of terminal objects can be proved without
      the @{prop stable_img} assumption.
›

    lemma terminal_char1:
    shows "terminal t  ide t  (∃!x. x  set t)"
    proof -
      have "terminal t  ide t  (∃!x. x  set t)"
      proof -
        assume t: "terminal t"
        have "ide t" using t terminal_def by auto
        moreover have "∃!x. x  set t"
        proof -
          have "∃!x. x  hom unity t"
            using t terminal_unity terminal_def by auto
          thus ?thesis using set_def by auto
        qed
        ultimately show "ide t  (∃!x. x  set t)" by auto
      qed
      moreover have "ide t  (∃!x. x  set t)  terminal t"
      proof -
        assume t: "ide t  (∃!x. x  set t)"
        from this obtain t' where "set t = {t'}" by blast
        hence t': "set t = {t'}  {t'}  Univ  t = mkIde {t'}"
          using t set_subset_Univ mkIde_set by metis
        show "terminal t"
        proof
          show "ide t" using t by simp
          show "a. ide a  ∃!f. «f : a  t»"
          proof -
            fix a
            assume a: "ide a"
            show "∃!f. «f : a  t»"
            proof
              show 1: "«mkArr (set a) {t'} (λx. t') : a  t»"
              proof
                show 2: "arr (mkArr (set a) {t'} (λx. t'))"
                  using a t t' cardinal set_card mkIde_set set_subset_Univ arr_mkArr
                  by force
                show "dom (mkArr (set a) {t'} (λx. t')) = a"
                  using a 2 mkIde_set by simp
                show "cod (mkArr (set a) {t'} (λx. t')) = t"
                  using t t' 2 by simp
              qed
              show "f. «f : a  t»  f = mkArr (set a) {t'} (λx. t')"
              proof -
                fix f
                assume f: "«f : a  t»"
                show "f = mkArr (set a) {t'} (λx. t')"
                proof (intro arr_eqI)
                  show 1: "par f (mkArr (set a) {t'} (λx. t'))" using 1 f in_homE by metis
                  show "Fun f = Fun (mkArr (set a) {t'} (λx. t'))"
                  proof -
                    have "Fun (mkArr (set a) {t'} (λx. t')) = (λxset a. t')"
                      using 1 Fun_mkArr by simp
                    also have "... = Fun f"
                    proof -
                      have "x. x  set a  Fun f x = t'"
                        using f t' Fun_def mkArr_Fun arr_mkArr
                        by (metis PiE in_homE singletonD)
                      moreover have "x. x  set a  Fun f x = undefined"
                        using f Fun_def by auto
                      ultimately show ?thesis by auto
                    qed
                    finally show ?thesis by force
                  qed
                qed
              qed
            qed
          qed
        qed
      qed
      ultimately show ?thesis by blast
    qed
    
    text‹
      As stated above, in the presence of the @{prop stable_img} assumption we have
      the following stronger characterization of terminal objects.
›

    lemma terminal_char2:
    shows "terminal t  ide t  set t = {t}"
    proof
      assume t: "terminal t"
      show "ide t  set t = {t}"
      proof
        show "ide t" using t terminal_char1 by auto
        show "set t = {t}"
        proof -
          have "∃!x. x  hom unity t" using t terminal_def terminal_unity by force
          moreover have "t  img ` hom unity t" using t stable_img set_def by simp
          ultimately show ?thesis using set_def by auto
        qed
      qed
      next
      assume "ide t  set t = {t}"
      thus "terminal t" using terminal_char1 by force
    qed

  end

  text‹
    At last, we define the set_category› locale by existentially quantifying
    out the choice of a particular @{term img} map.  We need to know that such a map
    exists, but it does not matter which one we choose.
›

  locale set_category = category S
  for S :: "'s comp"      (infixr "" 55)
  and 𝔄 :: "'t rel" +
  assumes ex_img: "img. set_category_given_img S img 𝔄"
  begin

    notation in_hom ("«_ : _  _»")
  
    definition some_img
    where "some_img = (SOME img. set_category_given_img S img 𝔄)"
   
  end
  
  sublocale set_category  set_category_given_img S some_img 𝔄
  proof -
    have "img. set_category_given_img S img 𝔄" using ex_img by auto
    thus "set_category_given_img S some_img 𝔄"
      using someI_ex [of "λimg. set_category_given_img S img 𝔄"] some_img_def
      by metis
  qed

  text‹
    For a set category, if the cardinal 𝔄› is large enough, then it imposes no constraint
    on what subsets of the universe determine objects.  In this case, we call the set category
    \emph{replete} and we can eliminate the cardinality assumptions from various facts.
  ›

  locale replete_set_category =
    set_category S ‹cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)
  for S :: "'s comp"      (infixr "" 55)
  begin

    lemma card_of_leq:
    assumes "A  Univ"
    shows "|A| <o cardSuc (cmax (card_of (UNIV :: 's set)) natLeq)"
    proof -
      have "|A| ≤o cmax (card_of (UNIV :: 's set)) natLeq"
        using assms card_of_Card_order natLeq_Card_order ordLeq_cmax1
              ordLeq_transitive
        by (metis card_of_UNIV)
      thus ?thesis
        by (simp add: Card_order_cmax natLeq_Card_order)
    qed

    lemma set_mkIde [simp]:
    assumes "A  Univ"
    shows "set (mkIde A) = A"
      using assms card_of_leq set_mkIde by simp

    lemma ide_mkIde [simp]:
    assumes "A  Univ"
    shows "ide (mkIde A)"
      using assms card_of_leq ide_mkIde by simp

    lemma arr_mkIde [iff]:
    shows "arr (mkIde A)  A  Univ"
      using card_of_leq arr_mkIde by auto

    lemma dom_mkIde [simp]:
    assumes "A  Univ"
    shows "dom (mkIde A) = mkIde A"
      using assms ide_mkIde by simp

    lemma cod_mkIde [simp]:
    assumes "A  Univ"
    shows "cod (mkIde A) = mkIde A"
      using assms ide_mkIde by simp

    lemma Fun_mkIde [simp]:
    assumes "A  Univ"
    shows "Fun (mkIde A) = restrict (λx. x) A"
      using assms set_mkIde ide_mkIde Fun_ide by simp

    lemma mkArr_in_hom [intro]:
    assumes "A  Univ" and "B  Univ" and "F  A  B"
    shows "«mkArr A B F : mkIde A  mkIde B»"
      using assms card_of_leq arr_mkArr by auto

    lemma arr_mkArr:
    shows "arr (mkArr A B F)  A  Univ  B  Univ  F  A  B"
      using card_of_leq arr_mkArr by auto

    lemma mkIde_as_mkArr:
    assumes "A  Univ"
    shows "mkArr A A (λx. x) = mkIde A"
      using assms card_of_leq set_mkIde arr_mkIde arr_mkArr dom_mkIde cod_mkIde Fun_mkIde
      by (intro arr_eqI, auto)

  end

  context set_category
  begin

    text‹
      The arbitrary choice of @{term img} induces a system of arrows corresponding
      to inclusions of subsets.
›

    definition incl :: "'s  bool"
    where "incl f = (arr f  set (dom f)  set (cod f) 
                     f = mkArr (set (dom f)) (set (cod f)) (λx. x))"

    lemma Fun_incl:
    assumes "incl f"
    shows "Fun f = (λx  set (dom f). x)"
      using assms incl_def by (metis Fun_mkArr)

    lemma ex_incl_iff_subset:
    assumes "ide a" and "ide b"
    shows "(f. «f : a  b»  incl f)  set a  set b"
    proof
      show "f. «f : a  b»  incl f  set a  set b"
        using incl_def by auto
      show "set a  set b  f. «f : a  b»  incl f"
      proof
        assume 1: "set a  set b"
        show "«mkArr (set a) (set b) (λx. x) : a  b»  incl (mkArr (set a) (set b) (λx. x))"
        proof
          show "«mkArr (set a) (set b) (λx. x) : a  b»"
          proof -
            have "(λx. x)  set a  set b" using 1 by auto
            thus ?thesis
              using assms mkArr_in_hom set_subset_Univ in_homI set_card arr_mkArr mkIde_set
              by auto
          qed
          thus "incl (mkArr (set a) (set b) (λx. x))"
            using 1 incl_def by force
        qed
      qed
    qed

  end

  section "Categoricity"

  text‹
    In this section we show that the set_category› locale completely characterizes
    the structure of its interpretations as categories, in the sense that for any two
    interpretations @{term S} and @{term S'} for the same cardinal 𝔄›,
    a bijection between the universe of @{term S} and the universe of @{term S'} extends
    to an isomorphism of @{term S} and @{term S'}.
›
  
  locale two_set_categories_bij_betw_Univ =
    S: set_category S 𝔄 +
    S': set_category S' 𝔄
  for S :: "'s comp"      (infixr "" 55)
  and S' :: "'t comp"     (infixr "⋅´" 55)
  and 𝔄 :: "'u rel"
  and φ :: "'s  't" +
  assumes bij_φ: "bij_betw φ S.Univ S'.Univ"
  begin

    notation S.in_hom     ("«_ : _  _»")
    notation S'.in_hom    ("«_ : _ →'' _»")

    abbreviation ψ
    where "ψ  inv_into S.Univ φ"

    lemma ψ_φ:
    assumes "t  S.Univ"
    shows (φ t) = t"
      using assms bij_φ bij_betw_inv_into_left by metis

    lemma φ_ψ:
    assumes "t'  S'.Univ"
    shows "φ (ψ t') = t'"
      using assms bij_φ bij_betw_inv_into_right by metis
    
    lemma ψ_img_φ_img:
    assumes "A  S.Univ"
    shows ` φ ` A = A"
      using assms bij_φ by (simp add: bij_betw_def)
      
    lemma φ_img_ψ_img:
    assumes "A'  S'.Univ"
    shows "φ ` ψ ` A' = A'"
      using assms bij_φ by (simp add: bij_betw_def image_inv_into_cancel)
  
    text‹
      We define the object map @{term Φo} of a functor from @{term[source=true] S}
      to @{term[source=true] S'}.
›

    definition Φo
    where "Φo = (λa  Collect S.ide. S'.mkIde (φ ` S.set a))"

    lemma set_Φo:
    assumes "S.ide a"
    shows "S'.set (Φo a) = φ ` S.set a"
    proof -
      from assms have "S.set a  S.Univ  |S.set a| <o 𝔄"
        by (simp add: S.set_card)
      moreover have "|φ ` S.set a| <o 𝔄"
        by (meson calculation card_of_image ordLeq_ordLess_trans)
      ultimately show ?thesis
        using S'.set_mkIde Φo_def assms bij_φ bij_betw_def image_mono mem_Collect_eq restrict_def
        by (metis (no_types, lifting))
    qed

    lemma Φo_preserves_ide:
    assumes "S.ide a"
    shows "S'.ide (Φo a)"
      using assms S'.ide_mkIde S.set_subset_Univ bij_φ bij_betw_def image_mono restrict_apply'
      unfolding Φo_def
      by (metis (no_types, lifting) S.set_card card_of_image mem_Collect_eq ordLeq_ordLess_trans)
      
    text‹
      The map @{term Φa} assigns to each arrow @{term f} of @{term[source=true] S} the function on
      the universe of @{term[source=true] S'} that is the same as the function induced by @{term f}
      on the universe of @{term[source=true] S}, up to the bijection @{term φ} between the two
      universes.
›

    definition Φa
    where "Φa = (λf. λx'  φ ` S.set (S.dom f). φ (S.Fun f (ψ x')))"
    
    lemma Φa_mapsto:
    assumes "S.arr f"
    shows "Φa f  S'.set (Φo (S.dom f))  S'.set (Φo (S.cod f))"
    proof -
      have "Φa f  φ ` S.set (S.dom f)  φ ` S.set (S.cod f)"
      proof
        fix x
        assume x: "x  φ ` S.set (S.dom f)"
        have x  S.set (S.dom f)"
          using assms x ψ_img_φ_img [of "S.set (S.dom f)"] S.set_subset_Univ by auto
        hence "S.Fun f (ψ x)  S.set (S.cod f)" using assms S.Fun_mapsto by auto
        hence "φ (S.Fun f (ψ x))  φ ` S.set (S.cod f)" by simp
        thus "Φa f x  φ ` S.set (S.cod f)" using x Φa_def by auto
      qed
      thus ?thesis using assms set_Φo Φo_preserves_ide by auto
    qed
    
    text‹
      The map @{term Φa} takes composition of arrows to extensional
      composition of functions.
›

    lemma Φa_comp:
    assumes gf: "S.seq g f"
    shows "Φa (g  f) = restrict (Φa g o Φa f) (S'.set (Φo (S.dom f)))"
    proof -
      have "Φa (g  f) = (λx'  φ ` S.set (S.dom f). φ (S.Fun (S g f) (ψ x')))"
        using gf Φa_def by auto
      also have "... = (λx'  φ ` S.set (S.dom f).
                           φ (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (ψ x')))"
        using gf set_Φo S.Fun_comp by simp
      also have "... = restrict (Φa g o Φa f) (S'.set (Φo (S.dom f)))"
      proof -
        have "x'. x'  φ ` S.set (S.dom f)
                  φ (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (ψ x')) = Φa g (Φa f x')"
        proof -
          fix x'
          assume X': "x'  φ ` S.set (S.dom f)"
          hence 1: x'  S.set (S.dom f)"
            using gf ψ_img_φ_img [of "S.set (S.dom f)"] S.set_subset_Univ S.ide_dom by blast
          hence "φ (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (ψ x'))
                   = φ (S.Fun g (S.Fun f (ψ x')))"
            using restrict_apply by auto
          also have "... = φ (S.Fun g (ψ (φ (S.Fun f (ψ x')))))"
          proof -
            have "S.Fun f (ψ x')  S.set (S.cod f)"
              using gf 1 S.Fun_mapsto by fast
            hence (φ (S.Fun f (ψ x'))) = S.Fun f (ψ x')"
              using assms bij_φ S.set_subset_Univ bij_betw_def inv_into_f_f subsetCE S.ide_cod
              by (metis S.seqE)
            thus ?thesis by auto
          qed
          also have "... = Φa g (Φa f x')"
          proof -
            have "Φa f x'  φ ` S.set (S.cod f)"
              using gf S.ide_dom S.ide_cod X' Φa_mapsto [of f] set_Φo [of "S.dom f"]
                    set_Φo [of "S.cod f"]
              by blast
            thus ?thesis using gf X' Φa_def by auto
          qed
          finally show "φ (restrict (S.Fun g o S.Fun f) (S.set (S.dom f)) (ψ x')) =
                        Φa g (Φa f x')"
            by auto
        qed
        thus ?thesis using assms set_Φo by fastforce
      qed
      finally show ?thesis by auto
    qed
    
    text‹
      Finally, we use @{term Φo} and @{term Φa} to define a functor @{term Φ}.
›

    definition Φ
    where "Φ f = (if S.arr f then
                     S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod f))) (Φa f)
                   else S'.null)"
    
    lemma Φ_in_hom:
    assumes "S.arr f"
    shows f  S'.hom (Φo (S.dom f)) (Φo (S.cod f))"
    proof -
      have "«Φ f : S'.dom (Φ f) →' S'.cod (Φ f)»"
        using assms Φ_def [of f] Φa_mapsto [of f] Φo_preserves_ide S'.set_card S'.arr_mkArr
        by (intro S'.in_homI) auto
      thus ?thesis
        using assms Φ_def Φa_mapsto Φo_preserves_ide S'.set_card S'.arr_mkArr S'.mkIde_set
        by auto
    qed

    lemma Φ_ide [simp]:
    assumes "S.ide a"
    shows a = Φo a"
    proof -
      have a = S'.mkArr (S'.set (Φo a)) (S'.set (Φo a)) (λx'. x')"
      proof -
        have "«Φ a : Φo a →' Φo a»"
          using assms Φ_in_hom S.ide_in_hom by fastforce
        moreover have "Φa a = restrict (λx'. x') (S'.set (Φo a))"
        proof -
          have "Φa a = (λx'  φ ` S.set a. φ (S.Fun a (ψ x')))"
            using assms Φa_def restrict_apply by auto
          also have "... = (λx'  S'.set (Φo a). φ (ψ x'))"
          proof -
            have "S.Fun a = (λx  S.set a. x)" using assms S.Fun_ide by simp
            moreover have "x'. x'  φ ` S.set a  ψ x'  S.set a"
              using assms bij_φ S.set_subset_Univ image_iff by (metis ψ_img_φ_img)
            ultimately show ?thesis
              using assms set_Φo by auto
          qed
          also have "... = restrict (λx'. x') (S'.set (Φo a))"
            using assms S'.set_subset_Univ Φo_preserves_ide φ_ψ
            by (meson restr_eqI subsetCE)
          ultimately show ?thesis by auto
        qed
        ultimately show ?thesis
          using assms Φ_def Φo_preserves_ide S'.mkArr_restrict_eq'
          by (metis S'.arrI S.ide_char)
      qed
      thus ?thesis
        using assms S'.mkIde_as_mkArr Φo_preserves_ide Φ_in_hom S'.set_card S'.mkIde_set
        by simp
    qed
    
    lemma set_dom_Φ:
    assumes "S.arr f"
    shows "S'.set (S'.dom (Φ f)) = φ ` (S.set (S.dom f))"
      using assms S.ide_dom Φ_in_hom Φ_ide set_Φo by fastforce
    
    lemma Φ_comp:
    assumes "S.seq g f"
    shows (g  f) = Φ g ⋅´ Φ f"
    proof -
      have (g  f) = S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod g))) (Φa (S g f))"
        using Φ_def assms by auto
      also have "... = S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod g)))
                                (restrict (Φa g o Φa f) (S'.set (Φo (S.dom f))))"
        using assms Φa_comp set_Φo by force
      also have "... = S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod g))) (Φa g o Φa f)"
      proof -
        have "S'.arr (S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod g))) (Φa g o Φa f))"
          using assms Φa_mapsto [of f] Φa_mapsto [of g] Φo_preserves_ide S'.arr_mkArr S'.set_card
          by (elim S.seqE, auto)
        thus ?thesis
          using assms S'.mkArr_restrict_eq by auto
      qed
      also have "... = S' (S'.mkArr (S'.set (Φo (S.dom g))) (S'.set (Φo (S.cod g))) (Φa g))
                          (S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod f))) (Φa f))"
      proof -
        have "S'.arr (S'.mkArr (S'.set (Φo (S.dom f))) (S'.set (Φo (S.cod f))) (Φa f))"
          using assms Φa_mapsto set_Φo S.ide_dom S.ide_cod Φo_preserves_ide
                S'.arr_mkArr S'.set_subset_Univ S.seqE S'.set_card
          by metis
        moreover have "S'.arr (S'.mkArr (S'.set (Φo (S.dom g))) (S'.set (Φo (S.cod g)))
                              (Φa g))"
          using assms Φa_mapsto set_Φo S.ide_dom S.ide_cod Φo_preserves_ide S'.arr_mkArr
                S'.set_subset_Univ S.seqE S'.set_card
          by metis
        ultimately show ?thesis using assms S'.comp_mkArr by force
      qed
      also have "... = Φ g ⋅´ Φ f" using assms Φ_def by force
      finally show ?thesis by fast
    qed
      
    interpretation Φ: "functor" S S' Φ
      apply unfold_locales
      using Φ_def
          apply simp
      using Φ_in_hom Φ_comp
      by auto

    lemma Φ_is_functor:
    shows "functor S S' Φ" ..
      
    lemma Fun_Φ:
    assumes "S.arr f" and "x  S.set (S.dom f)"
    shows "S'.Fun (Φ f) (φ x) = Φa f (φ x)"
      using assms Φ_def Φ.preserves_arr set_Φo by auto
      
    lemma Φ_acts_elementwise:
    assumes "S.ide a"
    shows "S'.set (Φ a) = Φ ` S.set a"
    proof
      have 0: "S'.set (Φ a) = φ ` S.set a"
        using assms Φ_ide set_Φo by simp
      have 1: "x. x  S.set a  Φ x = φ x"
      proof -
        fix x
        assume x: "x  S.set a"
        have 1: "S.terminal x" using assms x S.set_subset_Univ by blast
        hence 2: "S'.terminal (φ x)"
          by (metis CollectD CollectI bij_φ bij_betw_def image_iff)
        have x = Φo x"
          using assms x 1 Φ_ide S.terminal_def by auto
        also have "... = φ x"
        proof -
          have "Φo x = S'.mkIde (φ ` S.set x)"
            using assms 1 x Φo_def S.terminal_def by auto
          moreover have "S'.mkIde (φ ` S.set x) = φ x"
            using assms x 1 2 S.terminal_char2 S'.terminal_char2 S'.mkIde_set bij_φ
            by (metis image_empty image_insert)
          ultimately show ?thesis by auto
        qed
        finally show x = φ x" by auto
      qed
      show "S'.set (Φ a)  Φ ` S.set a" using 0 1 by force
      show ` S.set a  S'.set (Φ a)" using 0 1 by force
    qed

    lemma Φ_preserves_incl:
    assumes "S.incl m"
    shows "S'.incl (Φ m)"
    proof -
      have 1: "S.arr m  S.set (S.dom m)  S.set (S.cod m) 
               m = S.mkArr (S.set (S.dom m)) (S.set (S.cod m)) (λx. x)"
        using assms S.incl_def by blast
      have "S'.arr (Φ m)" using 1 by auto
      moreover have 2: "S'.set (S'.dom (Φ m))  S'.set (S'.cod (Φ m))"
        using 1 Φ.preserves_dom Φ.preserves_cod Φ_acts_elementwise
        by (metis (full_types) S.ide_cod S.ide_dom image_mono)
      moreover have m =
                     S'.mkArr (S'.set (S'.dom (Φ m))) (S'.set (S'.cod (Φ m))) (λx'. x')"
      proof -
        have m = S'.mkArr (S'.set (Φo (S.dom m))) (S'.set (Φo (S.cod m))) (Φa m)"
          using 1 Φ_def by simp
        also have "... = S'.mkArr (S'.set (S'.dom (Φ m))) (S'.set (S'.cod (Φ m))) (Φa m)"
          using 1 Φ_ide by auto
        finally have 3: m =
                         S'.mkArr (S'.set (S'.dom (Φ m))) (S'.set (S'.cod (Φ m))) (Φa m)"
          by auto
        also have "... = S'.mkArr (S'.set (S'.dom (Φ m))) (S'.set (S'.cod (Φ m))) (λx'. x')"
        proof -
          have 4: "S.Fun m = restrict (λx. x) (S.set (S.dom m))"
            using assms S.incl_def by (metis (full_types) S.Fun_mkArr)
          hence "Φa m = restrict (λx'. x') (φ ` (S.set (S.dom m)))"
          proof -
            have 5: "x'. x'  φ ` S.set (S.dom m)  φ (ψ x') = x'"
              by (metis 1 S'.set_subset_Univ S.ide_dom Φo_preserves_ide φ_ψ set_Φo subsetD)
            have "Φa m = restrict (λx'. φ (S.Fun m (ψ x'))) (φ ` S.set (S.dom m))"
              using Φa_def by simp
            also have "... = restrict (λx'. x') (φ ` S.set (S.dom m))"
            proof -
              have "x. x  φ ` (S.set (S.dom m))  φ (S.Fun m (ψ x)) = x"
              proof -
                fix x
                assume x: "x  φ ` (S.set (S.dom m))"
                hence x  S.set (S.dom m)"
                  using 1 S.ide_dom S.set_subset_Univ ψ_img_φ_img image_eqI by metis
                thus "φ (S.Fun m (ψ x)) = x" using 1 4 5 x by simp
              qed
              thus ?thesis by auto
            qed
            finally show ?thesis by auto
          qed
          hence "Φa m = restrict (λx'. x') (S'.set (S'.dom (Φ m)))"
            using 1 set_dom_Φ by auto
          thus ?thesis
            using 2 3 ‹S'.arr (Φ m) S'.mkArr_restrict_eq S'.ide_cod S'.ide_dom S'.incl_def
            by (metis S'.arr_mkArr image_restrict_eq image_subset_iff_funcset)
        qed
        finally show ?thesis by auto
      qed
      ultimately show ?thesis using S'.incl_def by blast
    qed

    text‹
      Interchange the role of @{term φ} and @{term ψ} to obtain a functor Ψ›
      from @{term[source=true] S'} to @{term[source=true] S}.
›

    interpretation INV: two_set_categories_bij_betw_Univ S' S 𝔄 ψ
      apply unfold_locales by (simp add: bij_φ bij_betw_inv_into)

    abbreviation Ψo
    where "Ψo  INV.Φo"

    abbreviation Ψa
    where "Ψa  INV.Φa"

    abbreviation Ψ
    where "Ψ  INV.Φ"

    interpretation Ψ: "functor" S' S Ψ
      using INV.Φ_is_functor by auto

    text‹
      The functors @{term Φ} and @{term Ψ} are inverses.
›

    lemma Fun_Ψ:
    assumes "S'.arr f'" and "x'  S'.set (S'.dom f')"
    shows "S.Fun (Ψ f') (ψ x') = Ψa f' (ψ x')"
      using assms INV.Fun_Φ by blast
          
    lemma Ψo_Φo:
    assumes "S.ide a"
    shows "Ψo (Φo a) = a"
      using assms Φo_def INV.Φo_def ψ_img_φ_img Φo_preserves_ide set_Φo S.mkIde_set
      by force
     
    lemma ΦΨ:
    assumes "S.arr f"
    shows (Φ f) = f"
    proof (intro S.arr_eqI)
      show par: "S.par (Ψ (Φ f)) f"
        using assms Φo_preserves_ide Ψo_Φo by auto
      show "S.Fun (Ψ (Φ f)) = S.Fun f"
      proof -
        have "S.arr (Ψ (Φ f))" using assms by auto
        moreover have (Φ f) = S.mkArr (S.set (S.dom f)) (S.set (S.cod f)) (Ψa (Φ f))"
          using assms INV.Φ_def Φ_in_hom Ψo_Φo by auto
        moreover have "Ψa (Φ f) = (λx  S.set (S.dom f). ψ (S'.Fun (Φ f) (φ x)))"
        proof -
          have "Ψa (Φ f) = (λx  ψ ` S'.set (S'.dom (Φ f)). ψ (S'.Fun (Φ f) (φ x)))"
          proof -
            have "x. x  ψ ` S'.set (S'.dom (Φ f))  INV.ψ x = φ x"
              using assms S.ide_dom S.set_subset_Univ Ψ.preserves_reflects_arr par bij_φ
                    inv_into_inv_into_eq subsetCE INV.set_dom_Φ
              by metis
            thus ?thesis
              using INV.Φa_def by auto
          qed
          moreover have ` S'.set (S'.dom (Φ f)) = S.set (S.dom f)"
            using assms by (metis par Ψ.preserves_reflects_arr INV.set_dom_Φ)
          ultimately show ?thesis by auto
        qed
        ultimately have 1: "S.Fun (Ψ (Φ f)) = (λx  S.set (S.dom f). ψ (S'.Fun (Φ f) (φ x)))"
          using S'.Fun_mkArr by simp
        show ?thesis
        proof
          fix x
          have "x  S.set (S.dom f)  S.Fun (Ψ (Φ f)) x = S.Fun f x"
            using 1 assms extensional_def S.Fun_mapsto S.Fun_def by auto
          moreover have "x  S.set (S.dom f)  S.Fun (Ψ (Φ f)) x = S.Fun f x"
          proof -
            assume x: "x  S.set (S.dom f)"
            have "S.Fun (Ψ (Φ f)) x = ψ (φ (S.Fun f (ψ (φ x))))"
              using assms x 1 Fun_Φ bij_φ Φa_def by auto
            also have "... = S.Fun f x"
            proof -
              have 2: "x. x  S.Univ  ψ (φ x) = x"
                using bij_φ bij_betw_inv_into_left by fast
              have "S.Fun f (ψ (φ x)) = S.Fun f x"
                using assms x 2
                by (metis S.ide_dom S.set_subset_Univ subsetCE)
              moreover have "S.Fun f x  S.Univ"
                using x assms S.Fun_mapsto S.set_subset_Univ S.ide_cod by blast
              ultimately show ?thesis using 2 by auto
            qed
            finally show ?thesis by auto
          qed
          ultimately show "S.Fun (Ψ (Φ f)) x = S.Fun f x" by auto
        qed
      qed
    qed

    lemma Φo_Ψo:
    assumes "S'.ide a'"
    shows "Φo (Ψo a') = a'"
      using assms Φo_def INV.Φo_def φ_img_ψ_img INV.Φo_preserves_ide ψ_φ INV.set_Φo
            S'.mkIde_set
      by force

    lemma ΨΦ:
    assumes "S'.arr f'"
    shows (Ψ f') = f'"
    proof (intro S'.arr_eqI)
      show par: "S'.par (Φ (Ψ f')) f'"
        using assms Φ.preserves_ide Ψ.preserves_ide Φ_ide INV.Φ_ide Φo_Ψo by auto
      show "S'.Fun (Φ (Ψ f')) = S'.Fun f'"
      proof -
        have "S'.arr (Φ (Ψ f'))" using assms by blast
        moreover have (Ψ f') =
                       S'.mkArr (S'.set (S'.dom f')) (S'.set (S'.cod f')) (Φa (Ψ f'))"
          using assms Φ_def INV.Φ_in_hom Φo_Ψo by simp
        moreover have "Φa (Ψ f') = (λx'  S'.set (S'.dom f'). φ (S.Fun (Ψ f') (ψ x')))"
          unfolding Φa_def
          using assms par Ψ.preserves_arr set_dom_Φ by metis
        ultimately have 1: "S'.Fun (Φ (Ψ f')) =
                            (λx'  S'.set (S'.dom f'). φ (S.Fun (Ψ f') (ψ x')))"
          using S'.Fun_mkArr by simp
        show ?thesis
        proof
          fix x'
          have "x'  S'.set (S'.dom f')  S'.Fun (Φ (Ψ f')) x' = S'.Fun f' x'"
            using 1 assms S'.Fun_mapsto extensional_def by (simp add: S'.Fun_def)
          moreover have "x'  S'.set (S'.dom f')  S'.Fun (Φ (Ψ f')) x' = S'.Fun f' x'"
          proof -
            assume x': "x'  S'.set (S'.dom f')"
            have "S'.Fun (Φ (Ψ f')) x' = φ (S.Fun (Ψ f') (ψ x'))"
              using x' 1 by auto
            also have "... = φ (Ψa f' (ψ x'))"
              using Fun_Ψ x' assms S'.set_subset_Univ bij_φ by metis
            also have "... = φ (ψ (S'.Fun f' (φ (ψ x'))))"
            proof -
              have "φ (Ψa f' (ψ x')) = φ (ψ (S'.Fun f' x'))"
              proof -
                have "x'  S'.Univ"
                  by (meson S'.ide_dom S'.set_subset_Univ assms subsetCE x')
                thus ?thesis
                  by (simp add: INV.Φa_def INV.ψ_φ x')
              qed
              also have "... = φ (ψ (S'.Fun f' (φ (ψ x'))))"
                using assms x' φ_ψ S'.set_subset_Univ S'.ide_dom by (metis subsetCE)
              finally show ?thesis by auto
            qed
            also have "... = S'.Fun f' x'"
            proof -
              have 2: "x'. x'  S'.Univ  φ (ψ x') = x'"
                using bij_φ bij_betw_inv_into_right by fast
              have "S'.Fun f' (φ (ψ x')) = S'.Fun f' x'"
                using assms x' 2 S'.set_subset_Univ S'.ide_dom by (metis subsetCE)
              moreover have "S'.Fun f' x'  S'.Univ"
                using x' assms S'.Fun_mapsto S'.set_subset_Univ S'.ide_cod by blast
              ultimately show ?thesis using 2 by auto
            qed
            finally show ?thesis by auto
          qed
          ultimately show "S'.Fun (Φ (Ψ f')) x' = S'.Fun f' x'" by auto
        qed
      qed
    qed
          
    lemma inverse_functors_Φ_Ψ:
    shows "inverse_functors S S' Ψ Φ"
    proof -
      interpret ΦΨ: composite_functor S S' S Φ Ψ ..
      have inv: o Φ = S.map"
        using ΦΨ S.map_def ΦΨ.is_extensional by auto
    
      interpret ΨΦ: composite_functor S' S S' Ψ Φ ..
      have inv': o Ψ = S'.map"
        using ΨΦ S'.map_def ΨΦ.is_extensional by auto
    
      show ?thesis
        using inv inv' by (unfold_locales, auto)
    qed
      
    lemma are_isomorphic:
    shows "Φ. invertible_functor S S' Φ  (m. S.incl m  S'.incl (Φ m))"
    proof -
      interpret inverse_functors S S' Ψ Φ
        using inverse_functors_Φ_Ψ by auto
      have 1: "inverse_functors S S' Ψ Φ" ..
      interpret invertible_functor S S' Φ
        apply unfold_locales using 1 by auto
      have "invertible_functor S S' Φ" ..
      thus ?thesis using Φ_preserves_incl by auto
    qed
    
  end
  
  text‹
    The main result: @{locale set_category} is categorical, in the following (logical) sense:
    If S› and S'› are two ``set categories'' for the same cardinal 𝔄›,
    and if the sets of terminal objects of S› and S'› are in bijective correspondence,
    then S› and S'› are isomorphic as categories, via a functor that preserves inclusion maps,
    hence the inclusion relation between sets.
  ›

  theorem set_category_is_categorical:
  assumes "set_category S 𝔄" and "set_category S' 𝔄"
  and "bij_betw φ (set_category_data.Univ S) (set_category_data.Univ S')"
  shows "Φ. invertible_functor S S' Φ 
             (m. set_category.incl S 𝔄 m  set_category.incl S' 𝔄 (Φ m))"
  proof -
    interpret S: set_category S using assms(1) by auto
    interpret S': set_category S' using assms(2) by auto
    interpret two_set_categories_bij_betw_Univ S S' 𝔄 φ
      apply (unfold_locales) using assms(3) by auto
    show ?thesis using are_isomorphic by auto
  qed
  
  section "Further Properties of Set Categories"

  text‹
    In this section we further develop the consequences of the set_category›
    axioms, and establish characterizations of a number of standard category-theoretic
    notions for a set_category›.
›

  context set_category
  begin
  
    abbreviation Dom
    where "Dom f  set (dom f)"
    
    abbreviation Cod
    where "Cod f  set (cod f)"

    subsection "Initial Object"

    text‹
      The object corresponding to the empty set is an initial object.
›

    definition empty
    where "empty = mkIde {}"

    lemma initial_empty:
    shows "initial empty"
    proof
      show 0: "ide empty"
        using empty_def ide_mkIde
        by (simp add: ide_mkIde_finite)
      show "b. ide b  ∃!f. «f : empty  b»"
      proof -
        fix b
        assume b: "ide b"
        show "∃!f. «f : empty  b»"
        proof
          show 1: "«mkArr {} (set b) (λx. x) : empty  b»"
            using 0 b empty_def mkArr_in_hom mkIde_set set_subset_Univ arr_mkIde
            by (metis (no_types, lifting) Pi_I empty_iff ide_def mkIde_def)
          show "f. «f : empty  b»  f = mkArr {} (set b) (λx. x)"
          proof -
            fix f
            assume f: "«f : empty  b»"
            show "f = mkArr {} (set b) (λx. x)"
            proof (intro arr_eqI)
              show 1: "par f (mkArr {} (set b) (λx. x))"
                using 1 f by force
              show "Fun f = Fun (mkArr {} (set b) (λx. x))"
                using empty_def 1 f Fun_mapsto arr_mkArr set_mkIde by fastforce
            qed
          qed
        qed
      qed
    qed

    subsection "Identity Arrows"
    
    text‹
      Identity arrows correspond to restrictions of the identity function.
›

    lemma ide_char:
    assumes "arr f"
    shows "ide f  Dom f = Cod f  Fun f = (λx  Dom f. x)"
      using assms mkIde_as_mkArr mkArr_Fun Fun_ide in_homE ide_cod mkArr_Fun mkIde_set
      by (metis ide_char)

    lemma ideI:
    assumes "arr f" and "Dom f = Cod f" and "x. x  Dom f  Fun f x = x"
    shows "ide f"
    proof -
      have "Fun f = (λx  Dom f. x)"
        using assms Fun_def by auto
      thus ?thesis using assms ide_char by blast
    qed

    subsection "Inclusions"
    
    lemma ide_implies_incl:
    assumes "ide a"
    shows "incl a"
    proof -
      have "arr a  Dom a  Cod a" using assms by auto
      moreover have "a = mkArr (Dom a) (Cod a) (λx. x)"
        using assms mkIde_as_mkArr mkIde_set set_card by simp
      ultimately show ?thesis using incl_def by simp
    qed
    
    definition incl_in :: "'s  's  bool"
    where "incl_in a b = (ide a  ide b  set a  set b)"
    
    abbreviation incl_of
    where "incl_of a b  mkArr (set a) (set b) (λx. x)"

    lemma elem_set_implies_set_eq_singleton:
    assumes "a  set b"
    shows "set a = {a}"
    proof -
      have "ide b" using assms set_def by auto
      thus ?thesis using assms set_subset_Univ terminal_char2
        by (metis mem_Collect_eq subsetCE)
    qed

    lemma elem_set_implies_incl_in:
    assumes "a  set b"
    shows "incl_in a b"
    proof -
      have b: "ide b" using assms set_def by auto
      hence "set b  Univ" by simp
      hence "a  Univ  set a  set b"
        using assms elem_set_implies_set_eq_singleton by auto
      hence "ide a  set a  set b"
        using b terminal_char1 by simp
      thus ?thesis using b incl_in_def by simp
    qed
    
    lemma incl_incl_of [simp]:
    assumes "incl_in a b"
    shows "incl (incl_of a b)"
    and "«incl_of a b : a  b»"
    proof -
      show "«incl_of a b : a  b»"
        using assms incl_in_def mkArr_in_hom mkIde_set set_subset_Univ
        by (metis image_ident image_subset_iff_funcset set_card)
      thus "incl (incl_of a b)"
        using assms incl_def incl_in_def by fastforce
    qed
    
    text‹
      There is at most one inclusion between any pair of objects.
›

    lemma incls_coherent:
    assumes "par f f'" and "incl f" and "incl f'"
    shows "f = f'"
      using assms incl_def fun_complete by auto

    text‹
      The set of inclusions is closed under composition.
›

    lemma incl_comp [simp]:
    assumes "incl f" and "incl g" and "cod f = dom g"
    shows "incl (g  f)"
    proof -
      have 1: "seq g f" using assms incl_def by auto
      moreover have 2: "Dom (g  f)  Cod (g  f)"
        using assms 1 incl_def by auto
      moreover have "g  f = mkArr (Dom f) (Cod g) (restrict (λx. x) (Dom f))"
      proof (intro arr_eqI)
        have 3: "arr (mkArr (Dom f) (Cod g) (λxDom f. x))"
          using assms 1 2
          by (metis cod_comp dom_comp ex_incl_iff_subset ide_cod ide_dom
              in_homE incl_def mkArr_restrict_eq)
        show 4: "par (g  f) (mkArr (Dom f) (Cod g) (λxDom f. x))"
          using assms 1 3 mkIde_set by auto
        show "Fun (g  f) = Fun (mkArr (Dom f) (Cod g) (λxDom f. x))"
          using assms 3 4 Fun_comp Fun_mkArr
          by (metis Fun_ide comp_cod_arr ide_cod mkArr_restrict_eq' incl_def)
      qed
      ultimately show ?thesis using incl_def arr_mkArr set_mkIde by force
    qed

    subsection "Image Factorization"

    text‹
      The image of an arrow is the object that corresponds to the set-theoretic
      image of the domain set under the function induced by the arrow.
›

    abbreviation Img
    where "Img f  Fun f ` Dom f"

    definition img
    where "img f = mkIde (Img f)"

    lemma ide_img [simp]:
    assumes "arr f"
    shows "ide (img f)"
    proof -
      have "Fun f ` Dom f  Cod f" using assms Fun_mapsto by blast
      moreover have "Cod f  Univ  |Cod f| <o 𝔄"
        using assms by (simp add: set_card)
      ultimately have "Fun f ` Dom f  Univ  |Fun f ` Dom f| <o 𝔄"
        by (meson assms card_of_image ide_dom ordLeq_ordLess_trans set_card subset_eq)
      thus ?thesis using img_def ide_mkIde by simp
    qed
    
    lemma set_img [simp]:
    assumes "arr f"
    shows "set (img f) = Img f"
    proof -
      have "Fun f ` set (dom f)  set (cod f)  set (cod f)  Univ"
        using assms Fun_mapsto by auto
      hence "Fun f ` set (dom f)  Univ  |Fun f ` Dom f| <o 𝔄"
        by (metis assms ide_def ide_img img_def mkIde_def)
      thus ?thesis using assms img_def set_mkIde by auto
    qed

    lemma img_point_in_Univ:
    assumes "«x : unity  a»"
    shows "img x  Univ"
    proof -
      have "set (img x) = {Fun x unity}"
        using assms img_def terminal_unity terminal_char2
              image_empty image_insert mem_Collect_eq set_img
        by force
      thus "img x  Univ" using assms terminal_char1 by auto
    qed

    lemma incl_in_img_cod:
    assumes "arr f"
    shows "incl_in (img f) (cod f)"
    proof (unfold img_def)
      have 1: "Img f  Cod f  Cod f  Univ  |Cod f| <o 𝔄"
        using assms Fun_mapsto
        by (metis arr_mkArr image_subset_iff_funcset mkArr_Fun)
      hence 2: "ide (mkIde (Img f))"
        using assms ide_img img_def by auto
      moreover have "set (mkIde (Img f))  Cod f"
        using 1 2
        by (metis ideD(1) arr_mkIde set_mkIde)
      ultimately show "incl_in (mkIde (Img f)) (cod f)"
        using assms incl_in_def ide_cod by blast
    qed

    lemma img_point_elem_set:
    assumes "«x : unity  a»"
    shows "img x  set a"
    proof -
      have "incl_in (img x) a"
        using assms incl_in_img_cod by auto
      hence "set (img x)  set a"
        using incl_in_def by blast
      moreover have "img x  set (img x)"
        using assms img_point_in_Univ terminal_char2 by simp
      ultimately show ?thesis by auto
    qed

    text‹
      The corestriction of an arrow @{term f} is the arrow
      @{term "corestr f  hom (dom f) (img f)"} that induces the same function
      on the universe as @{term f}.
›

    definition corestr
    where "corestr f = mkArr (Dom f) (Img f) (Fun f)"
    
    lemma corestr_in_hom:
    assumes "arr f"
    shows "«corestr f : dom f  img f»"
    proof -
      have "Fun f  Dom f  Fun f ` Dom f  Dom f  Univ"
        using assms by auto
      moreover have "Fun f ` Dom f  Univ"
      proof -
        have "Fun f ` Dom f  Cod f  Cod f  Univ"
          using assms Fun_mapsto by auto
        thus ?thesis by blast
      qed
      moreover have "|Fun f ` Dom f| <o 𝔄"
        using assms by (metis ide_img set_card set_img)
      ultimately have "mkArr (Dom f) (Fun f ` Dom f) (Fun f)  hom (dom f) (img f)"
        using assms img_def mkArr_in_hom [of "Dom f" "Fun f ` Dom f" "Fun f"] mkIde_set
        by (simp add: set_card)
      thus ?thesis using corestr_def by fastforce
    qed
    
    text‹
      Every arrow factors as a corestriction followed by an inclusion.
›

    lemma img_fact:
    assumes "arr f"
    shows "S (incl_of (img f) (cod f)) (corestr f) = f"
    proof (intro arr_eqI)
      have 1: "«corestr f : dom f  img f»"
        using assms corestr_in_hom by blast
      moreover have 2: "«incl_of (img f) (cod f) : img f  cod f»"
        using assms incl_in_img_cod incl_incl_of by fast
      ultimately show P: "par (incl_of (img f) (cod f)  corestr f) f"
        using assms in_homE by blast
      show "Fun (incl_of (img f) (cod f)  corestr f) = Fun f"
      proof -
        have "Fun (incl_of (img f) (cod f)  corestr f)
                 = restrict (Fun (incl_of (img f) (cod f)) o Fun (corestr f)) (Dom f)"
          using Fun_comp 1 2 P by auto
        also have
           "... = restrict (restrict (λx. x) (Img f) o restrict (Fun f) (Dom f)) (Dom f)"
        proof -
          have "Fun (corestr f) = restrict (Fun f) (Dom f)"
            using assms corestr_def Fun_mkArr corestr_in_hom by force
          moreover have "Fun (incl_of (img f) (cod f)) = restrict (λx. x) (Img f)"
          proof -
            have "arr (incl_of (img f) (cod f))" using incl_incl_of P by blast
            moreover have "incl_of (img f) (cod f) = mkArr (Img f) (Cod f) (λx. x)"
              using assms by fastforce
            ultimately show ?thesis using assms img_def Fun_mkArr by metis
          qed
          ultimately show ?thesis by argo
        qed
        also have "... = Fun f"
         proof
          fix x
          show "restrict (restrict (λx. x) (Img f) o restrict (Fun f) (Dom f)) (Dom f) x = Fun f x"
            using assms extensional_restrict Fun_mapsto extensional_arb [of "Fun f" "Dom f" x]
            by (cases "x  Dom f", auto)
        qed
        finally show ?thesis by auto
      qed
    qed

    lemma Fun_corestr:
    assumes "arr f"
    shows "Fun (corestr f) = Fun f"
    proof -
      have 1: "f = incl_of (img f) (cod f)  corestr f"
        using assms img_fact by auto
      hence 2: "Fun f = restrict (Fun (incl_of (img f) (cod f)) o Fun (corestr f)) (Dom f)"
        using assms by (metis Fun_comp dom_comp)
      also have "... = restrict (Fun (corestr f)) (Dom f)"
        using assms by (metis 1 2 Fun_mkArr seqE mkArr_Fun corestr_def)
      also have "... = Fun (corestr f)"
        using assms 1 by (metis Fun_def dom_comp extensional_restrict restrict_extensional)
      finally show ?thesis by auto
    qed
    
    subsection "Points and Terminal Objects"

    text‹
      To each element @{term t} of @{term "set a"} is associated a point
      @{term "mkPoint a t  hom unity a"}.  The function induced by such
      a point is the constant-@{term t} function on the set @{term "{unity}"}.
›

    definition mkPoint
    where "mkPoint a t  mkArr {unity} (set a) (λ_. t)"

    lemma mkPoint_in_hom:
    assumes "ide a" and "t  set a"
    shows "«mkPoint a t : unity  a»"
      using assms mkArr_in_hom mkIde_set set_subset_Univ terminal_char2 terminal_unity
            mkPoint_def set_card
      by (metis Pi_I)

    lemma Fun_mkPoint:
    assumes "ide a" and "t  set a"
    shows "Fun (mkPoint a t) = (λ_  {unity}. t)"
      using assms mkPoint_def mkPoint_in_hom Fun_mkArr by force

    text‹
      For each object @{term a} the function @{term "mkPoint a"} has as its inverse
      the restriction of the function @{term img} to @{term "hom unity a"}

    lemma mkPoint_img:
    shows "img  hom unity a  set a"
    and "x. «x : unity  a»  mkPoint a (img x) = x"
    proof -
      show "img  hom unity a  set a"
        using img_point_elem_set by simp
      show "x. «x : unity  a»  mkPoint a (img x) = x"
      proof -
        fix x
        assume x: "«x : unity  a»"
        show "mkPoint a (img x) = x"
        proof (intro arr_eqI)
          have 0: "img x  set a"
            using x img_point_elem_set by metis
          hence 1: "mkPoint a (img x)  hom unity a"
            using x mkPoint_in_hom by force
          thus 2: "par (mkPoint a (img x)) x"
            using x by fastforce
          have "Fun (mkPoint a (img x)) = (λ_  {unity}. img x)"
            using 1 mkPoint_def by auto
          also have "... = Fun x"
          proof
            fix z
            have "z  unity  (λ_  {unity}. img x) z = Fun x z"
              using x Fun_mapsto Fun_def restrict_apply singletonD terminal_char2 terminal_unity
              by auto
            moreover have "(λ_  {unity}. img x) unity = Fun x unity"
            proof -
              have "(λ_  {unity}. img x) unity = img x"
                by simp
              also have "... = Fun x unity"
                using x 0 elem_set_implies_set_eq_singleton set_img terminal_char2 terminal_unity
                by (metis (no_types, lifting) image_insert in_homE singleton_insert_inj_eq')
              finally show ?thesis by blast
            qed
            ultimately show "(λ_  {unity}. img x) z = Fun x z" by auto
          qed
          finally show "Fun (mkPoint a (img x)) = Fun x" by auto
        qed
      qed
    qed

    lemma img_mkPoint:
    assumes "ide a"
    shows "mkPoint a  set a  hom unity a"
    and "t. t  set a  img (mkPoint a t) = t"
    proof -
      show "mkPoint a  set a  hom unity a"
        using assms(1) mkPoint_in_hom by simp
      show "t. t  set a  img (mkPoint a t) = t"
        proof -
        fix t
        assume t: "t  set a"
        show "img (mkPoint a t) = t"
        proof -
          have 1: "arr (mkPoint a t)"
            using assms t mkPoint_in_hom by auto
          have "Fun (mkPoint a t) ` {unity} = {t}"
            using 1 mkPoint_def by simp
          thus ?thesis
            by (metis 1 t elem_set_implies_incl_in elem_set_implies_set_eq_singleton img_def
                      incl_in_def dom_mkArr mkIde_set terminal_char2 terminal_unity mkPoint_def)
        qed
      qed
    qed

    text‹
      For each object @{term a} the elements of @{term "hom unity a"} are therefore in
      bijective correspondence with @{term "set a"}.
›

    lemma bij_betw_points_and_set:
    assumes "ide a"
    shows "bij_betw img (hom unity a) (set a)"
    proof (intro bij_betwI)
      show "img  hom unity a  set a"
        using assms mkPoint_img by auto
      show "mkPoint a  set a  hom unity a"
        using assms img_mkPoint by auto
      show "x. x  hom unity a  mkPoint a (img x) = x"
        using assms mkPoint_img by auto
      show "t. t  set a  img (mkPoint a t) = t"
        using assms img_mkPoint by auto
    qed

    text‹
      The function on the universe induced by an arrow @{term f} agrees, under the bijection
      between @{term "hom unity (dom f)"} and @{term "Dom f"}, with the action of @{term f}
      by composition on @{term "hom unity (dom f)"}.
›

    lemma Fun_point:
    assumes "«x : unity  a»"
    shows "Fun x = (λ_  {unity}. img x)"
      using assms mkPoint_img img_mkPoint Fun_mkPoint [of a "img x"] img_point_elem_set
      by auto

    lemma comp_arr_mkPoint:
    assumes "arr f" and "t  Dom f"
    shows "f  mkPoint (dom f) t = mkPoint (cod f) (Fun f t)"
    proof (intro arr_eqI)
      have 0: "seq f (mkPoint (dom f) t)"
        using assms mkPoint_in_hom [of "dom f" t] by auto
      have 1: "«f  mkPoint (dom f) t : unity  cod f»"
        using assms mkPoint_in_hom [of "dom f" t] by auto
      show "par (f  mkPoint (dom f) t) (mkPoint (cod f) (Fun f t))"
      proof -
        have "«mkPoint (cod f) (Fun f t) : unity  cod f»"
          using assms Fun_mapsto mkPoint_in_hom [of "cod f" "Fun f t"] by auto
        thus ?thesis using 1 by fastforce
      qed
      show "Fun (f  mkPoint (dom f) t) = Fun (mkPoint (cod f) (Fun f t))"
      proof -
        have "Fun (f  mkPoint (dom f) t) = restrict (Fun f o Fun (mkPoint (dom f) t)) {unity}"
          using assms 0 1 Fun_comp terminal_char2 terminal_unity by auto
        also have "... = (λ_  {unity}. Fun f t)"
          using assms Fun_mkPoint by auto
        also have "... = Fun (mkPoint (cod f) (Fun f t))"
          using assms Fun_mkPoint [of "cod f" "Fun f t"] Fun_mapsto by fastforce
        finally show ?thesis by auto
      qed
    qed

    lemma comp_arr_point:
    assumes "arr f" and "«x : unity  dom f»"
    shows "f  x = mkPoint (cod f) (Fun f (img x))"
    proof -
      have "x = mkPoint (dom f) (img x)" using assms mkPoint_img by simp
      thus ?thesis using assms comp_arr_mkPoint [of f "img x"]
        by (simp add: img_point_elem_set)
    qed

    text‹
      This agreement allows us to express @{term "Fun f"} in terms of composition.
›

    lemma Fun_in_terms_of_comp:
    assumes "arr f"
    shows "Fun f = restrict (img o S f o mkPoint (dom f)) (Dom f)"
    proof
      fix t
      have "t  Dom f  Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t"
        using assms by (simp add: Fun_def)
      moreover have "t  Dom f 
                     Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t"
      proof -
        assume t: "t  Dom f"
        have 1: "f  mkPoint (dom f) t = mkPoint (cod f) (Fun f t)"
          using assms t comp_arr_mkPoint by simp
        hence "img (f  mkPoint (dom f) t) = img (mkPoint (cod f) (Fun f t))" by simp
        thus ?thesis
        proof -
          have "Fun f t  Cod f" using assms t Fun_mapsto by auto
          thus ?thesis using assms t 1 img_mkPoint by auto
        qed
      qed
      ultimately show "Fun f t = restrict (img o S f o mkPoint (dom f)) (Dom f) t" by auto
    qed

    text‹
      We therefore obtain a rule for proving parallel arrows equal by showing
      that they have the same action by composition on points.
›

    (*
     * TODO: Find out why attempts to use this as the main rule for a proof loop
     * unless the specific instance is given.
     *)
    lemma arr_eqI':
    assumes "par f f'" and "x. «x : unity  dom f»  f  x = f'  x"
    shows "f = f'"
      using assms Fun_in_terms_of_comp mkPoint_in_hom by (intro arr_eqI, auto)

    text‹
      An arrow can therefore be specified by giving its action by composition on points.
      In many situations, this is more natural than specifying it as a function on the universe.
›

    definition mkArr'
    where "mkArr' a b F = mkArr (set a) (set b) (img o F o mkPoint a)"

    lemma mkArr'_in_hom:
    assumes "ide a" and "ide b" and "F  hom unity a  hom unity b"
    shows "«mkArr' a b F : a  b»"
    proof -
      have "img o F o mkPoint a  set a  set b"
      proof
        fix t
        assume t: "t  set a"
        thus "(img o F o mkPoint a) t  set b"
          using assms mkPoint_in_hom img_point_elem_set [of "F (mkPoint a t)" b]
          by auto
      qed
      thus ?thesis
        using assms mkArr'_def mkArr_in_hom [of "set a" "set b"] set_card mkIde_set by simp
    qed

    lemma comp_point_mkArr':
    assumes "ide a" and "ide b" and "F  hom unity a  hom unity b"
    shows "x. «x : unity  a»  mkArr' a b F  x = F x"
    proof -
      fix x
      assume x: "«x : unity  a»"
      have "Fun (mkArr' a b F) (img x) = img (F x)"
        unfolding mkArr'_def
        using assms x Fun_mkArr arr_mkArr img_point_elem_set mkPoint_img mkPoint_in_hom
        by (simp add: set_card Pi_iff)
      hence "mkArr' a b F  x = mkPoint b (img (F x))"
        using assms x mkArr'_in_hom [of a b F] comp_arr_point by auto
      thus "mkArr' a b F  x = F x"
        using assms x mkPoint_img(2) by auto
    qed

    text‹
      A third characterization of terminal objects is as those objects whose set of
      points is a singleton.
›

    lemma terminal_char3:
    assumes "∃!x. «x : unity  a»"
    shows "terminal a"
    proof -
      have a: "ide a"
        using assms ide_cod mem_Collect_eq by blast
      hence 1: "bij_betw img (hom unity a) (set a)"
        using assms bij_betw_points_and_set by auto
      hence "img ` (hom unity a) = set a"
        by (simp add: bij_betw_def)
      moreover have "hom unity a = {THE x. x  hom unity a}"
        using assms theI' [of "λx. x  hom unity a"] by auto
      ultimately have "set a = {img (THE x. x  hom unity a)}"
        by (metis image_empty image_insert)
      thus ?thesis using a terminal_char1 by simp
    qed

    text‹
      The following is an alternative formulation of functional completeness, which says that
      any function on points uniquely determines an arrow.
›

    lemma fun_complete':
    assumes "ide a" and "ide b" and "F  hom unity a  hom unity b"
    shows "∃!f. «f : a  b»  (x. «x : unity  a»  f  x = F x)"
    proof
      have 1: "«mkArr' a b F : a  b»" using assms mkArr'_in_hom by auto
      moreover have 2: "x. «x : unity  a»  mkArr' a b F  x = F x"
        using assms comp_point_mkArr' by auto
      ultimately show "«mkArr' a b F : a  b» 
                       (x. «x : unity  a»  mkArr' a b F  x = F x)" by blast
      fix f
      assume f: "«f : a  b»  (x. «x : unity  a»  f  x = F x)"
      show "f = mkArr' a b F"
        using f 1 2 by (intro arr_eqI' [of f "mkArr' a b F"], fastforce, auto)
    qed

    subsection "The `Determines Same Function' Relation on Arrows"

    text‹
      An important part of understanding the structure of a category of sets and functions
      is to characterize when it is that two arrows ``determine the same function''.
      The following result provides one answer to this: two arrows with a common domain
      determine the same function if and only if they can be rendered equal by composing with
      a cospan of inclusions.
›

    lemma eq_Fun_iff_incl_joinable:
    assumes "span f f'"
    shows "Fun f = Fun f' 
           (m m'. incl m  incl m'  seq m f  seq m' f'  m  f = m'  f')"
    proof
      assume ff': "Fun f = Fun f'"
      let ?b = "mkIde (Cod f  Cod f')"
      let ?m = "incl_of (cod f) ?b"
      let ?m' = "incl_of (cod f') ?b"
      have 1: "|Cod f  Cod f'| <o 𝔄"
        using assms set_card cardinal card_order_infinite_isLimOrd by simp
      have incl_m: "incl ?m"
        using assms 1 incl_incl_of [of "cod f" ?b] incl_in_def ide_mkIde set_mkIde by simp
      have incl_m': "incl ?m'"
        using assms 1 incl_incl_of [of "cod f'" ?b] incl_in_def ide_mkIde set_mkIde by simp
      have m: "?m = mkArr (Cod f) (Cod f  Cod f') (λx. x)"
        by (simp add: assms 1 set_mkIde)
      have m': "?m' = mkArr (Cod f') (Cod f  Cod f') (λx. x)"
        by (simp add: assms 1 set_mkIde)
      have seq: "seq ?m f  seq ?m' f'"
        using assms m m'
        by (metis ide_cod incl_m incl_m' mkIde_set seqI incl_def dom_mkArr)
      have "?m  f = ?m'  f'"
      proof (intro arr_eqI)
        show par: "par (?m  f) (?m'  f')"
          using assms m m'
          by (metis cod_comp cod_mkArr dom_comp seq seqE)
        show "Fun (?m  f) = Fun (?m'  f')"
          using assms ff'
          by (metis incl_m incl_m' comp_mkArr incl_def mkArr_Fun)
      qed
      hence "incl ?m  incl ?m'  seq ?m f  seq ?m' f'  ?m  f = ?m'  f'"
        using seq ‹incl ?m ‹incl ?m' by simp
      thus "m m'. incl m  incl m'  seq m f  seq m' f'  m  f = m'  f'" by auto
      next
      assume ff': "m m'. incl m  incl m'  seq m f  seq m' f'  m  f = m'  f'"
      show "Fun f = Fun f'"
        using ff'
        by (metis Fun_comp Fun_ide comp_cod_arr ide_cod seqE Fun_incl)
    qed

    text‹
      Another answer to the same question: two arrows with a common domain determine the
      same function if and only if their corestrictions are equal.
›

    lemma eq_Fun_iff_eq_corestr:
    assumes "span f f'"
    shows "Fun f = Fun f'  corestr f = corestr f'"
      using assms corestr_def Fun_corestr by metis

    subsection "Retractions, Sections, and Isomorphisms"

    text‹
      An arrow is a retraction if and only if its image coincides with its codomain.
›

    lemma retraction_if_Img_eq_Cod:
    assumes "arr g" and "Img g = Cod g"
    shows "retraction g"
    and "ide (g  mkArr (Cod g) (Dom g) (inv_into (Dom g) (Fun g)))"
    proof -
      let ?F = "inv_into (Dom g) (Fun g)"
      let ?f = "mkArr (Cod g) (Dom g) ?F"
      have f: "arr ?f"
      proof -
        have "Cod g  Univ  Dom g  Univ" using assms by auto
        moreover have "|Cod g| <o 𝔄  |Dom g| <o 𝔄"
          using assms by (simp add: set_card)
        moreover have "?F  Cod g  Dom g"
        proof
          fix y
          assume y: "y  Cod g"
          let ?P = "λx. x  Dom g  Fun g x = y"
          have "x. ?P x" using y assms by force
          hence "?P (SOME x. ?P x)" using someI_ex [of ?P] by fast
          hence "?P (?F y)" using Hilbert_Choice.inv_into_def by metis
          thus "?F y  Dom g" by auto
        qed
        ultimately show ?thesis
          using arr_mkArr by auto
      qed
      show "ide (g  ?f)"
      proof -
        have "g = mkArr (Dom g) (Cod g) (Fun g)" using assms mkArr_Fun by auto
        hence "g  ?f = mkArr (Cod g) (Cod g) (Fun g o ?F)"
          using assms(1) f comp_mkArr by metis
        moreover have "mkArr (Cod g) (Cod g) (λy. y) = ..."
        proof (intro mkArr_eqI')
          show "arr (mkArr (Cod g) (Cod g) (λy. y))"
            using assms arr_cod_iff_arr set_card arr_mkArr by auto
          show "y. y  Cod g  y = (Fun g o ?F) y"
            using assms by (simp add: f_inv_into_f)
        qed
        ultimately show ?thesis
          using assms f mkIde_as_mkArr arr_mkArr mkIde_set by auto
      qed
      thus "retraction g" by auto
    qed

    lemma retraction_char:
    shows "retraction g  arr g  Img g = Cod g"
    proof
      assume G: "retraction g"
      show "arr g  Img g = Cod g"
      proof
        show "arr g" using G by blast
        show "Img g = Cod g"
        proof -
          from G obtain f where f: "ide (g  f)" by blast
          have "restrict (Fun g o Fun f) (Cod g) = restrict (λx. x) (Cod g)"
            using f Fun_comp Fun_ide ide_compE by metis
          hence "Fun g ` Fun f ` Cod g = Cod g"
            by (metis image_comp image_ident image_restrict_eq)
          moreover have "Fun f ` Cod g  Dom g"
            using f Fun_mapsto arr_mkArr mkArr_Fun funcset_image
            by (metis seqE ide_compE ide_compE)
          moreover have "Img g  Cod g"
            using f Fun_mapsto by blast
          ultimately show ?thesis by blast
        qed
      qed
      next
      assume "arr g  Img g = Cod g"
      thus "retraction g" using retraction_if_Img_eq_Cod by blast
    qed

    text‹
      Every corestriction is a retraction.
›

    lemma retraction_corestr:
    assumes "arr f"
    shows "retraction (corestr f)"
      using assms retraction_char Fun_corestr corestr_in_hom arr_mkArr by force

    text‹
      An arrow is a section if and only if it induces an injective function on its
      domain, except in the special case that it has an empty domain set and a
      nonempty codomain set.
›

    lemma section_if_inj:
    assumes "arr f" and "inj_on (Fun f) (Dom f)" and "Dom f = {}  Cod f = {}"
    shows "section f"
    and "ide (mkArr (Cod f) (Dom f)
                    (λy. if y  Img f then SOME x. x  Dom f  Fun f x = y
                         else SOME x. x  Dom f)
                 f)"
    proof -
      let ?P= "λy. λx. x  Dom f  Fun f x = y"
      let ?G = "λy. if y  Img f then SOME x. ?P y x else SOME x. x  Dom f"
      let ?g = "mkArr (Cod f) (Dom f) ?G"
      have g: "arr ?g"
      proof -
        have 1: "Cod f  Univ" using assms by simp
        have 2: "Dom f  Univ" using assms by simp
        have 3: "|Cod f| <o 𝔄  |Dom f| <o 𝔄"
          using assms set_card by simp
        have 4: "?G  Cod f  Dom f"
        proof
          fix y
          assume Y: "y  Cod f"
          show "?G y  Dom f"
          proof (cases "y  Img f")
            assume "y  Img f"
            hence "(x. ?P y x)  ?G y = (SOME x. ?P y x)" using Y by auto
            hence "?P y (?G y)" using someI_ex [of "?P y"] by argo
            thus "?G y  Dom f" by auto
            next
            assume "y  Img f"
            hence "(x. x  Dom f)  ?G y = (SOME x. x  Dom f)" using assms Y by auto
            thus "?G y  Dom f" using someI_ex [of "λx. x  Dom f"] by argo
          qed
        qed
        show ?thesis using 1 2 3 4 arr_mkArr by simp
      qed
      show "ide (?g  f)"
      proof -
        have "f = mkArr (Dom f) (Cod f) (Fun f)" using assms mkArr_Fun by auto
        hence "?g  f = mkArr (Dom f) (Dom f) (?G o Fun f)"
          using assms(1) g comp_mkArr [of "Dom f" "Cod f" "Fun f" "Dom f" ?G] by argo
        moreover have "mkArr (Dom f) (Dom f) (λx. x) = ..."
        proof (intro mkArr_eqI')
          show "arr (mkArr (Dom f) (Dom f) (λx. x))"
            using assms set_card arr_mkArr by auto
          show "x. x  Dom f  x = (?G o Fun f) x"
          proof -
            fix x
            assume x: "x  Dom f"
            have "Fun f x  Img f" using x by blast
            hence *: "(x'. ?P (Fun f x) x')  ?G (Fun f x) = (SOME x'. ?P (Fun f x) x')"
              by auto
            then have "?P (Fun f x) (?G (Fun f x))"
              using someI_ex [of "?P (Fun f x)"] by argo
            with * have "x = ?G (Fun f x)"
              using assms x inj_on_def [of "Fun f" "Dom f"] by simp
            thus "x = (?G o Fun f) x" by simp
          qed
        qed
        ultimately show ?thesis
          using assms set_card mkIde_as_mkArr mkIde_set by auto
      qed
      thus "section f" by auto
    qed

    lemma section_char:
    shows "section f  arr f  (Dom f = {}  Cod f = {})  inj_on (Fun f) (Dom f)"
    proof
      assume f: "section f"
      from f obtain g where g: "ide (g  f)" using section_def by blast
      show "arr f  (Dom f = {}  Cod f = {})  inj_on (Fun f) (Dom f)"
      proof -
        have "arr f" using f by blast
        moreover have "Dom f = {}  Cod f = {}"
        proof -
          have "Cod f  {}  Dom f  {}"
          proof
            assume "Cod f  {}"
            from this obtain y where "y  Cod f" by blast
            hence "Fun g y  Dom f"
              using g Fun_mapsto
              by (metis seqE ide_compE image_eqI retractionI retraction_char)
            thus "Dom f  {}" by blast
          qed
          thus ?thesis by auto
        qed
        moreover have "inj_on (Fun f) (Dom f)"
        proof -
          have "restrict (Fun g o Fun f) (Dom f) = Fun (g  f)"
            using g Fun_comp by (metis Fun_comp ide_compE)
          also have "... = restrict (λx. x) (Dom f)"
            using g Fun_ide by auto
          finally have "restrict (Fun g o Fun f) (Dom f) = restrict (λx. x) (Dom f)" by auto
          thus ?thesis using inj_onI inj_on_imageI2 inj_on_restrict_eq by metis
        qed
        ultimately show ?thesis by auto
      qed
      next
      assume F: "arr f  (Dom f = {}  Cod f = {})  inj_on (Fun f) (Dom f)"
      thus "section f" using section_if_inj by auto
    qed

    text‹
      Section-retraction pairs can also be characterized by an inverse relationship
      between the functions they induce.
›

    lemma section_retraction_char:
    shows "ide (g  f)  antipar f g  compose (Dom f) (Fun g) (Fun f) = (λx  Dom f. x)"
    proof
      show "ide (g  f)  antipar f g  compose (Dom f) (Fun g) (Fun f) = (λx  Dom f. x)"
      proof -
        assume fg: "ide (g  f)"
        have 1: "antipar f g" using fg by force
        moreover have "compose (Dom f) (Fun g) (Fun f) = (λx  Dom f. x)"
        proof
          fix x
          have "x  Dom f  compose (Dom f) (Fun g) (Fun f) x = (λx  Dom f. x) x"
            by (simp add: compose_def)
          moreover have "x  Dom f 
                         compose (Dom f) (Fun g) (Fun f) x = (λx  Dom f. x) x"
            using fg 1 Fun_comp by (metis Fun_comp Fun_ide compose_eq' ide_compE)
          ultimately show "compose (Dom f) (Fun g) (Fun f) x = (λx  Dom f. x) x" by auto
        qed
        ultimately show ?thesis by auto
      qed
      show "antipar f g  compose (Dom f) (Fun g) (Fun f) = (λx  Dom f. x)  ide (g  f)"
      proof -
        assume fg: "antipar f g  compose (Dom f) (Fun g) (Fun f) = (λx  Dom f. x)"
        show "ide (g  f)"
        proof -
          have 1: "arr (g  f)" using fg by auto
          moreover have "Dom (g  f) = Cod (S g f)"
            using fg 1 by force
          moreover have "Fun (g  f) = (λx  Dom (g  f). x)"
            using fg 1 by force
          ultimately show ?thesis using 1 ide_char by blast
        qed
      qed
    qed

    text‹
      Antiparallel arrows @{term f} and @{term g} are inverses if the functions
      they induce are inverses.
›

    lemma inverse_arrows_char:
    shows "inverse_arrows f g 
             antipar f g  compose (Dom f) (Fun g) (Fun f) = (λx  Dom f. x)
                          compose (Dom g) (Fun f) (Fun g) = (λy  Dom g. y)"
      using section_retraction_char by blast

    text‹
      An arrow is an isomorphism if and only if the function it induces is a bijection.
›

    lemma iso_char:
    shows "iso f  arr f  bij_betw (Fun f) (Dom f) (Cod f)"
    proof -
      have "iso f  section f  retraction f"
        using iso_iff_section_and_retraction by auto
      also have "...  arr f  inj_on (Fun f) (Dom f)  Img f = Cod f"
        using section_char retraction_char by force
      also have "...  arr f  bij_betw (Fun f) (Dom f) (Cod f)"
        using inj_on_def bij_betw_def [of "Fun f" "Dom f" "Cod f"] by meson
      finally show ?thesis by auto
    qed

    text‹
      The inverse of an isomorphism is constructed by inverting the induced function.
›

    lemma inv_char:
    assumes "iso f"
    shows "inv f = mkArr (Cod f) (Dom f) (inv_into (Dom f) (Fun f))"
    proof -
      let ?g = "mkArr (Cod f) (Dom f) (inv_into (Dom f) (Fun f))"
      have "ide (f  ?g)"
        using assms iso_is_retraction retraction_char retraction_if_Img_eq_Cod by simp
      moreover have "ide (?g  f)"
      proof -
        let ?g' = "mkArr (Cod f) (Dom f)
                         (λy. if y  Img f then SOME x. x  Dom f  Fun f x = y
                              else SOME x. x  Dom f)"
        have 1: "ide (?g'  f)"
          using assms iso_is_section section_char section_if_inj by simp
        moreover have "?g' = ?g"
        proof
          show "arr ?g'" using 1 ide_compE by blast
          show "y. y  Cod f  (if y  Img f then SOME x. x  Dom f  Fun f x = y
                                                  else SOME x. x  Dom f)
                                     = inv_into (Dom f) (Fun f) y"
          proof -
            fix y
            assume "y  Cod f"
            hence "y  Img f" using assms iso_is_retraction retraction_char by metis
            thus "(if y  Img f then SOME x. x  Dom f  Fun f x = y
                   else SOME x. x  Dom f)
                     = inv_into (Dom f) (Fun f) y"
              using inv_into_def by metis
          qed
        qed
        ultimately show ?thesis by auto
      qed
      ultimately have "inverse_arrows f ?g" by auto
      thus ?thesis using inverse_unique by blast
    qed

    lemma Fun_inv:
    assumes "iso f"
    shows "Fun (inv f) = restrict (inv_into (Dom f) (Fun f)) (Cod f)"
      using assms inv_in_hom inv_char iso_inv_iso iso_is_arr Fun_mkArr by metis

    subsection "Monomorphisms and Epimorphisms"

    text‹
      An arrow is a monomorphism if and only if the function it induces is injective.
›

    lemma mono_char:
    shows "mono f  arr f  inj_on (Fun f) (Dom f)"
    proof
      assume f: "mono f"
      hence "arr f" using mono_def by auto
      moreover have "inj_on (Fun f) (Dom f)"
      proof (intro inj_onI)
        have 0: "inj_on (S f) (hom unity (dom f))"
        proof -
          have "hom unity (dom f)  {g. seq f g}"
            using f mono_def arrI by auto
          hence "A. hom unity (dom f)  A  inj_on (S f) A"
            using f mono_def by auto
          thus ?thesis
            by (meson subset_inj_on)
        qed
        fix x x'
        assume x: "x  Dom f" and x': "x'  Dom f" and xx': "Fun f x = Fun f x'"
        have 1: "mkPoint (dom f) x  hom unity (dom f) 
                 mkPoint (dom f) x'  hom unity (dom f)"
          using x x' ‹arr f mkPoint_in_hom by simp
        have "f  mkPoint (dom f) x = f  mkPoint (dom f) x'"
          using ‹arr f x x' xx' comp_arr_mkPoint by simp
        hence "mkPoint (dom f) x = mkPoint (dom f) x'"
          using 0 1 inj_onD [of "S f" "hom unity (dom f)" "mkPoint (dom f) x"] by simp
        thus "x = x'"
          using ‹arr f x x' img_mkPoint(2) img_mkPoint(2) ide_dom by metis
      qed
      ultimately show "arr f  inj_on (Fun f) (Dom f)" by auto
      next
      assume f: "arr f  inj_on (Fun f) (Dom f)"
      show "mono f"
      proof
        show "arr f" using f by auto
        show "g g'. seq f g  seq f g'  f  g = f  g'  g = g'"
        proof -
          fix g g'
          assume gg': "seq f g  seq f g'  f  g = f  g'"
          show "g = g'"
          proof (intro arr_eqI)
            show par: "par g g'"
              using gg' dom_comp by (metis seqE)
            show "Fun g = Fun g'"
            proof
              fix x
              have "x  Dom g  Fun g x = Fun g' x"
                using gg' by (simp add: par Fun_def)
              moreover have "x  Dom g  Fun g x = Fun g' x"
              proof -
                assume x: "x  Dom g"
                have "Fun f (Fun g x) = Fun (f  g) x"
                  using gg' x Fun_comp [of f g] by auto
                also have "... = Fun f (Fun g' x)"
                  using par f gg' x monoE by simp
                finally have "Fun f (Fun g x) = Fun f (Fun g' x)" by auto
                moreover have "Fun g x  Dom f  Fun g' x  Dom f"
                  using par gg' x Fun_mapsto by fastforce
                ultimately show "Fun g x = Fun g' x"
                  using f gg' inj_onD [of "Fun f" "Dom f" "Fun g x" "Fun g' x"]
                  by simp
              qed
              ultimately show "Fun g x = Fun g' x" by auto
            qed
          qed
        qed
      qed
    qed

    text‹
      Inclusions are monomorphisms.
›

    lemma mono_imp_incl:
    assumes "incl f"
    shows "mono f"
      using assms incl_def Fun_incl mono_char by auto

    text‹
      A monomorphism is a section, except in case it has an empty domain set and
      a nonempty codomain set.
›

    lemma mono_imp_section:
    assumes "mono f" and "Dom f = {}  Cod f = {}"
    shows "section f"
      using assms mono_char section_char by auto

    text‹
      An arrow is an epimorphism if and only if either its image coincides with its
      codomain, or else the universe has only a single element (in which case all arrows
      are epimorphisms).
›

    lemma epi_char:
    shows "epi f  arr f  (Img f = Cod f  (t t'. t  Univ  t'  Univ  t = t'))"
    proof
      assume epi: "epi f"
      show "arr f  (Img f = Cod f  (t t'. t  Univ  t'  Univ  t = t'))"
      proof -
        have f: "arr f" using epi epi_implies_arr by auto
        moreover have "¬(t t'. t  Univ  t'  Univ  t = t')  Img f = Cod f"
        proof -
          assume "¬(t t'. t  Univ  t'  Univ  t = t')"
          from this obtain tt and ff
            where B: "tt  Univ  ff  Univ  tt  ff" by blast
          show "Img f = Cod f"
          proof
            show "Img f  Cod f" using f Fun_mapsto by auto
            show "Cod f  Img f"
            proof
              let ?g = "mkArr (Cod f) {ff, tt} (λy. tt)"
              let ?g' = "mkArr (Cod f) {ff, tt} (λy. if x. x  Dom f  Fun f x = y
                                                     then tt else ff)"
              let ?b = "mkIde {ff, tt}"
              have b: "ide ?b"
                using B ide_mkIde_finite by simp
              have g: "«?g : cod f  ?b»  Fun ?g = (λy  Cod f. tt)"
              proof -
                have "arr ?g"
                proof -
                  have "arr (mkIde {ff, tt})"
                    using b ideD(1) by presburger
                  thus ?thesis
                    by (simp add: f set_card arr_mkIde arr_mkArr)
                qed
                thus ?thesis
                  using f b B in_homI [of ?g] mkIde_set by simp
              qed
              have g': "?g'  hom (cod f) ?b 
                        Fun ?g' = (λy  Cod f. if x. x  Dom f  Fun f x = y then tt else ff)"
              proof -
                have "arr ?g"
                proof -
                  have "arr (mkIde {ff, tt})"
                    using b ideD(1) by presburger
                  thus ?thesis
                    by (simp add: f set_card arr_mkIde arr_mkArr)
                qed
                thus ?thesis
                  using f b B in_homI [of ?g'] arr_mkArr mkIde_set by simp
              qed
              have "?g  f = ?g'  f"
              proof (intro arr_eqI)
                show "par (?g  f) (?g'  f)"
                  using f g g' arr_mkArr by auto
                show "Fun (?g  f) = Fun (?g'  f)"
                  using f g g' Fun_comp comp_mkArr by fastforce
              qed
              hence gg': "?g = ?g'"
                using epi f g g' epiE [of f ?g ?g'] by fastforce
              fix y
              assume y: "y  Cod f"
              have "Fun ?g' y = tt" using gg' g y by simp
              hence "(if x. x  Dom f  Fun f x = y then tt else ff) = tt"
                using g' y by simp
              hence "x. x  Dom f  Fun f x = y"
                using B by argo
              thus "y  Img f" by blast
            qed
          qed
        qed
        ultimately show "arr f  (Img f = Cod f  (t t'. t  Univ  t'  Univ  t = t'))"
          by fast
      qed
      next
      show "arr f  (Img f = Cod f  (t t'. t  Univ  t'  Univ  t = t'))  epi f"
      proof -
        have "arr f  Img f = Cod f  epi f"
        proof -
          assume f: "arr f  Img f = Cod f"
          show "epi f"
            using f arr_eqI' epiE retractionI retraction_if_Img_eq_Cod retraction_is_epi
            by meson
        qed
        moreover have "arr f  (t t'. t  Univ  t'  Univ  t = t')  epi f"
        proof -
          assume f: "arr f  (t t'. t  Univ  t'  Univ  t = t')"
          have "f f'. par f f'  f = f'"
          proof -
            fix f f'
            assume ff': "par f f'"
            show "f = f'"
            proof (intro arr_eqI)
              show "par f f'" using ff' by simp
              have "t t'. t  Cod f  t'  Cod f  t = t'"
                using f ff' set_subset_Univ ide_cod subsetD by blast
              thus "Fun f = Fun f'"
                using ff' Fun_mapsto [of f] Fun_mapsto [of f']
                      extensional_arb [of "Fun f" "Dom f"] extensional_arb [of "Fun f'" "Dom f"]
                by fastforce
            qed
          qed
          moreover have "g g'. par (g  f) (g'  f)  par g g'"
            by force
          ultimately show "epi f"
            using f by (intro epiI; metis)
        qed
        ultimately show "arr f  (Img f = Cod f   (t t'. t  Univ  t'  Univ  t = t'))
                            epi f"
          by auto
      qed
    qed

    text‹
      An epimorphism is a retraction, except in the case of a degenerate universe with only
      a single element.
›

    lemma epi_imp_retraction:
    assumes "epi f" and "t t'. t  Univ  t'  Univ  t  t'"
    shows "retraction f"
      using assms epi_char retraction_char by auto

    text‹
      Retraction/inclusion factorization is unique (not just up to isomorphism -- remember
      that the notion of inclusion is not categorical but depends on the arbitrarily chosen
      @{term img}).
›

    lemma unique_retr_incl_fact:
    assumes "seq m e" and "seq m' e'" and "m  e = m'  e'"
    and "incl m" and "incl m'" and "retraction e" and "retraction e'"
    shows "m = m'" and "e = e'"
    proof -
      have 1: "cod m = cod m'  dom e = dom e'"
        using assms(1-3) by (metis dom_comp cod_comp)
      hence 2: "span e e'" using assms(1-2) by blast
      hence 3: "Fun e = Fun e'"
        using assms eq_Fun_iff_incl_joinable by meson
      hence "img e = img e'" using assms 1 img_def by auto
      moreover have "img e = cod e  img e' = cod e'"
        using assms(6-7) retraction_char img_def mkIde_set by simp
      ultimately have "par e e'" using 2 by simp
      thus "e = e'" using 3 arr_eqI by blast
      hence "par m m'" using assms(1) assms(2) 1 by fastforce
      thus "m = m'" using assms(4) assms(5) incls_coherent by blast
    qed

  end

  section "Concrete Set Categories"

  text‹
    The set_category› locale is useful for stating results that depend on a
    category of @{typ 'a}-sets and functions, without having to commit to a particular
    element type @{typ 'a}.  However, in applications we often need to work with a
    category of sets and functions that is guaranteed to contain sets corresponding
    to the subsets of some extrinsically given type @{typ 'a}.
    A \emph{concrete set category} is a set category S› that is equipped
    with an injective function @{term ι} from type @{typ 'a} to S.Univ›.
    The following locale serves to facilitate some of the technical aspects of passing
    back and forth between elements of type @{typ 'a} and the elements of S.Univ›.
›

  locale concrete_set_category = set_category S 𝔄
    for S :: "'s comp"      (infixr "S" 55)
    and 𝔄 :: "'t rel"
    and U :: "'a set"
    and ι :: "'a  's" +
    assumes ι_mapsto: "ι  U  Univ"
    and inj_ι: "inj_on ι U"
  begin

    abbreviation 𝗈
    where "𝗈  inv_into U ι"

    lemma 𝗈_mapsto:
    shows "𝗈  ι ` U  U"
      by (simp add: inv_into_into)

    lemma 𝗈_ι [simp]:
    assumes "x  U"
    shows "𝗈 (ι x) = x"
      using assms inj_ι inv_into_f_f by simp
      
    lemma ι_𝗈 [simp]:
    assumes "t  ι ` U"
    shows "ι (𝗈 t) = t"
      using assms o_def inj_ι by auto

  end

  locale replete_concrete_set_category =
    replete_set_category S +
    concrete_set_category S ‹cardSuc (cmax (card_of (UNIV :: 's set)) natLeq) U ι
    for S :: "'s comp"      (infixr "S" 55)
    and U :: "'a set"
    and ι :: "'a  's"

end

Theory SetCat

(*  Title:       SetCat
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter SetCat

theory SetCat
imports SetCategory ConcreteCategory
begin

  text‹
    This theory proves the consistency of the set_category› locale by giving
    a particular concrete construction of an interpretation for it.
    Applying the general construction given by @{locale concrete_category},
    we define arrows to be terms MkArr A B F›, where A› and B› are sets
    and F› is an extensional function that maps A› to B›.
›

  text‹
    This locale uses an extra dummy parameter just to fix the element type for sets.
    Without this, a type is used for each interpretation, which makes it impossible to
    construct set categories whose element types are related to the context.
  ›

  locale setcat =
  fixes dummy :: 'e
  and 𝔄 :: "'a rel"
  assumes cardinal: "Card_order 𝔄  infinite (Field 𝔄)"
  begin

    lemma finite_imp_card_less:
    assumes "finite A"
    shows "|A| <o 𝔄"
    proof -
      have "finite (Field |A| )"
        using assms by simp
      thus ?thesis
        using cardinal card_of_Well_order card_order_on_def finite_ordLess_infinite
        by blast
    qed

    type_synonym 'b arr = "('b set, 'b  'b) concrete_category.arr"

    interpretation concrete_category {A :: 'e set. |A| <o 𝔄} λA B. extensional A  (A  B)
                     λA. λx  A. x λC B A g f. compose A g f
      using compose_Id Id_compose
      apply unfold_locales
          apply auto[3]
       apply blast
      by (metis IntD2 compose_assoc)

    abbreviation comp :: "'e setcat.arr comp"     (infixr "" 55)
    where "comp  COMP"
    notation in_hom                               ("«_ : _  _»")

    lemma MkArr_expansion:
    assumes "arr f"
    shows "f = MkArr (Dom f) (Cod f) (λx  Dom f. Map f x)"
    proof (intro arr_eqI)
      show "arr f" by fact
      show "arr (MkArr (Dom f) (Cod f) (λx  Dom f. Map f x))"
        using assms arr_char
        by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
      show "Dom f = Dom (MkArr (Dom f) (Cod f) (λx  Dom f. Map f x))"
        by simp
      show "Cod f = Cod (MkArr (Dom f) (Cod f) (λx  Dom f. Map f x))"
        by simp
      show "Map f = Map (MkArr (Dom f) (Cod f) (λx  Dom f. Map f x))"
        using assms arr_char
        by (metis (mono_tags, lifting) Int_iff MkArr_Map extensional_restrict)
    qed

    lemma arr_char:
    shows "arr f  f  Null  |Dom f| <o 𝔄  |Cod f| <o 𝔄 
                     Map f  extensional (Dom f)  (Dom f  Cod f)"
      using arr_char by auto

    lemma terminal_char:
    shows "terminal a  (x. a = MkIde {x})"
    proof
      show "x. a = MkIde {x}  terminal a"
      proof -
        assume a: "x. a = MkIde {x}"
        from this obtain x where x: "a = MkIde {x}" by blast
        have "terminal (MkIde {x})"
        proof
          show 1: "ide (MkIde {x})"
            using finite_imp_card_less ide_MkIde by auto
          show "a. ide a  ∃!f. «f : a  MkIde {x}»"
          proof
            fix a :: "'e setcat.arr"
            assume a: "ide a"
            show "«MkArr (Dom a) {x} (λ_Dom a. x) : a  MkIde {x}»"
            proof
              show 2: "arr (MkArr (Dom a) {x} (λ_  Dom a. x))"
                using a 1 arr_MkArr [of "Dom a" "{x}"] ide_char by force
              show "dom (MkArr (Dom a) {x} (λ_  Dom a. x)) = a"
                using a 2 dom_MkArr by force
              show "cod (MkArr (Dom a) {x} (λ_Dom a. x)) = MkIde {x}"
                using 2 cod_MkArr by blast
            qed
            fix f :: "'e setcat.arr"
            assume f: "«f : a  MkIde {x}»"
            show "f = MkArr (Dom a) {x} (λ_  Dom a. x)"
            proof -
              have 1: "Dom f = Dom a  Cod f = {x}"
                using a f by (metis (mono_tags, lifting) Dom.simps(1) in_hom_char)
              moreover have "Map f = (λ_  Dom a. x)"
              proof
                fix z
                have "z  Dom a  Map f z = (λ_  Dom a. x) z"
                  using f 1 MkArr_expansion
                  by (metis (mono_tags, lifting) Map.simps(1) in_homE restrict_apply)
                moreover have "z  Dom a  Map f z = (λ_  Dom a. x) z"
                  using f 1 arr_char [of f] by fastforce
                ultimately show "Map f z = (λ_  Dom a. x) z" by auto
              qed
              ultimately show ?thesis
               using f MkArr_expansion [of f] by fastforce
            qed
          qed
        qed
        thus "terminal a" using x by simp
      qed
      show "terminal a  x. a = MkIde {x}"
      proof -
        assume a: "terminal a"
        hence ide_a: "ide a" using terminal_def by auto
        have 1: "∃!x. x  Dom a"
        proof -
          have "Dom a = {}  ¬terminal a"
          proof -
            assume "Dom a = {}"
            hence 1: "a = MkIde {}"
              using MkIde_Dom' ‹ide a by fastforce
            have "f. f  hom (MkIde {undefined}) (MkIde ({} :: 'e set))
                          Map f  {undefined}  {}"
            proof -
              fix f
              assume f: "f  hom (MkIde {undefined}) (MkIde ({} :: 'e set))"
              show "Map f  {undefined}  {}"
                using f MkArr_expansion arr_char [of f] in_hom_char by auto
            qed
            hence "hom (MkIde {undefined}) a = {}" using 1 by auto
            moreover have "ide (MkIde {undefined})"
              using finite_imp_card_less
              by (metis (mono_tags, lifting) finite.intros(1-2) ide_MkIde mem_Collect_eq)
            ultimately show "¬terminal a" by blast
          qed
          moreover have "x x'. x  Dom a  x'  Dom a  x  x'  ¬terminal a"
          proof -
            fix x x'
            assume 1: "x  Dom a  x'  Dom a  x  x'"
            let ?f = "MkArr {undefined} (Dom a) (λ_  {undefined}. x)"
            let ?f' = "MkArr {undefined} (Dom a) (λ_  {undefined}. x')"
            have "«?f : MkIde {undefined}  a»"
            proof
              show 2: "arr ?f"
              proof (intro arr_MkArr)
                show "{undefined}  {A. |A| <o 𝔄}"
                  by (simp add: finite_imp_card_less)
                show "Dom a  {A. |A| <o 𝔄}"
                  using ide_a ide_char by blast
                show "(λ_  {undefined}. x)  extensional {undefined}  ({undefined}  Dom a)"
                  using 1 by blast
              qed
              show "dom ?f = MkIde {undefined}"
                using 2 dom_MkArr by auto
              show "cod ?f = a"
                using 2 cod_MkArr ide_a by force
            qed
            moreover have "«?f' : MkIde {undefined}  a»"
            proof
              show 2: "arr ?f'"
                using 1 ide_a ide_char arr_MkArr [of "{undefined}" "Dom a"]
                      finite_imp_card_less
              proof (intro arr_MkArr)
                show "{undefined}  {A. |A| <o 𝔄}"
                  by (simp add: finite_imp_card_less)
                show "Dom a  {A. |A| <o 𝔄}"
                  using ide_a ide_char by blast
                show "(λ_  {undefined}. x')  extensional {undefined}  ({undefined}  Dom a)"
                  using 1 by blast
              qed
              show "dom ?f' = MkIde {undefined}"
                using 2 dom_MkArr by auto
              show "cod ?f' = a"
                using 2 cod_MkArr ide_a by force
            qed
            moreover have "?f  ?f'"
              using 1 by (metis arr.inject restrict_apply' singletonI)
            ultimately show "¬terminal a"
              using terminal_arr_unique
              by (metis (mono_tags, lifting) in_homE)
          qed
          ultimately show ?thesis
            using a by auto
        qed
        hence "Dom a = {THE x. x  Dom a}"
          using theI [of "λx. x  Dom a"] by auto
        hence "a = MkIde {THE x. x  Dom a}"
          using a terminal_def by (metis (mono_tags, lifting) MkIde_Dom')
        thus "x. a = MkIde {x}"
          by auto
      qed
    qed

    definition IMG :: "'e setcat.arr  'e setcat.arr"
    where "IMG f = MkIde (Map f ` Dom f)"
  
    interpretation set_category_data comp IMG ..

    lemma terminal_unity:
    shows "terminal unity"
      using terminal_char unity_def someI_ex [of terminal]
      by (metis (mono_tags, lifting))
  
    text‹
      The inverse maps @{term UP} and @{term DOWN} are used to pass back and forth between
      the inhabitants of type @{typ 'a} and the corresponding terminal objects.
      These are exported so that a client of the theory can relate the concrete
      element type @{typ 'a} to the otherwise abstract arrow type.
›

    definition UP :: "'e  'e setcat.arr"
    where "UP x  MkIde {x}"
  
    definition DOWN :: "'e setcat.arr  'e"
    where "DOWN t  the_elem (Dom t)"

    abbreviation U
    where "U  DOWN unity"
  
    lemma UP_mapsto:
    shows "UP  UNIV  Univ"
      using terminal_char UP_def by fast
    
    lemma DOWN_mapsto:
    shows "DOWN  Univ  UNIV"
      by auto
    
    lemma DOWN_UP [simp]:
    shows "DOWN (UP x) = x"
      by (simp add: DOWN_def UP_def)
    
    lemma UP_DOWN [simp]:
    assumes "t  Univ"
    shows "UP (DOWN t) = t"
      using assms terminal_char UP_def DOWN_def
      by (metis (mono_tags, lifting) mem_Collect_eq DOWN_UP)
  
    lemma inj_UP:
    shows "inj UP"
      by (metis DOWN_UP injI)
  
    lemma bij_UP:
    shows "bij_betw UP UNIV Univ"
    proof (intro bij_betwI)
      interpret category comp using is_category by auto
      show DOWN_UP: "x :: 'e. DOWN (UP x) = x" by simp
      show UP_DOWN: "t. t  Univ  UP (DOWN t) = t" by simp
      show "UP  UNIV  Univ" using UP_mapsto by auto
      show "DOWN  Collect terminal  UNIV" by auto
    qed
  
    lemma Dom_terminal:
    assumes "terminal t"
    shows "Dom t = {DOWN t}"
      using assms UP_def
      by (metis (mono_tags, lifting) Dom.simps(1) DOWN_def terminal_char the_elem_eq)

    text‹
      The image of a point @{term "p  hom unity a"} is a terminal object, which is given
      by the formula @{term "(UP o Fun p o DOWN) unity"}.
›

    lemma IMG_point:
    assumes "«p : unity  a»"
    shows "IMG  hom unity a  Univ"
    and "IMG p = (UP o Map p o DOWN) unity"
    proof -
      show "IMG  hom unity a  Univ"
      proof
        fix f
        assume f: "f  hom unity a"
        have "terminal (MkIde (Map f ` Dom unity))"
        proof -
          obtain u :: 'e where u: "unity = MkIde {u}"
            using terminal_unity terminal_char
            by (metis (mono_tags, lifting))
          have "Map f ` Dom unity = {Map f u}"
            using u by simp
          thus ?thesis
            using terminal_char by auto
        qed
        hence "MkIde (Map f ` Dom unity)  Univ" by simp
        moreover have "MkIde (Map f ` Dom unity) = IMG f"
          using f IMG_def in_hom_char
          by (metis (mono_tags, lifting) mem_Collect_eq)
        ultimately show "IMG f  Univ" by auto
      qed
      have "IMG p = MkIde (Map p ` Dom p)" using IMG_def by blast
      also have "... = MkIde (Map p ` {U})"
        using assms in_hom_char terminal_unity Dom_terminal
        by (metis (mono_tags, lifting))
      also have "... = (UP o Map p o DOWN) unity" by (simp add: UP_def)
      finally show "IMG p = (UP o Map p o DOWN) unity" using assms by auto
    qed
  
    text‹
      The function @{term IMG} is injective on @{term "hom unity a"} and its inverse takes
      a terminal object @{term t} to the arrow in @{term "hom unity a"} corresponding to the
      constant-@{term t} function.
›

    abbreviation MkElem :: "'e setcat.arr => 'e setcat.arr => 'e setcat.arr"
    where "MkElem t a  MkArr {U} (Dom a) (λ_  {U}. DOWN t)"

    lemma MkElem_in_hom:
    assumes "arr f" and "x  Dom f"
    shows "«MkElem (UP x) (dom f) : unity  dom f»"
    proof -
      have "(λ_  {U}. DOWN (UP x))  {U}  Dom (dom f)"
        using assms dom_char [of f] by simp
      moreover have "MkIde {U} = unity"
        using terminal_char terminal_unity
        by (metis (mono_tags, lifting) DOWN_UP UP_def)
      moreover have "MkIde (Dom (dom f)) = dom f"
        using assms dom_char MkIde_Dom' ide_dom by blast
      ultimately show ?thesis
        using assms MkArr_in_hom [of "{U}" "Dom (dom f)" "λ_  {U}. DOWN (UP x)"]
        by (metis (no_types, lifting) Dom.simps(1) Dom_in_Obj IntI arr_dom ideD(1)
            restrict_extensional terminal_def terminal_unity)
    qed

    lemma MkElem_IMG:
    assumes "p  hom unity a"
    shows "MkElem (IMG p) a = p"
    proof -
      have 0: "IMG p = UP (Map p U)"
        using assms IMG_point(2) by auto
      have 1: "Dom p = {U}"
        using assms terminal_unity Dom_terminal
        by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
      moreover have "Cod p = Dom a"
        using assms
        by (metis (mono_tags, lifting) in_hom_char mem_Collect_eq)
      moreover have "Map p = (λ_  {U}. DOWN (IMG p))"
      proof
        fix e
        show "Map p e = (λ_  {U}. DOWN (IMG p)) e"
        proof -
          have "Map p e = (λx  Dom p. Map p x) e"
            using assms MkArr_expansion [of p]
            by (metis (mono_tags, lifting) CollectD Map.simps(1) in_homE)
          also have "... = (λ_  {U}. DOWN (IMG p)) e"
            using assms 0 1 by simp
          finally show ?thesis by blast
        qed
      qed
      ultimately show "MkElem (IMG p) a = p"
        using assms MkArr_Map CollectD
        by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
    qed

    lemma inj_IMG:
    assumes "ide a"
    shows "inj_on IMG (hom unity a)"
    proof (intro inj_onI)
      fix x y
      assume x: "x  hom unity a"
      assume y: "y  hom unity a"
      assume eq: "IMG x = IMG y"
      show "x = y"
      proof (intro arr_eqI)
        show "arr x" using x by blast
        show "arr y" using y by blast
        show "Dom x = Dom y"
          using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
        show "Cod x = Cod y"
          using x y in_hom_char by (metis (mono_tags, lifting) CollectD)
        show "Map x = Map y"
        proof -
          have "a. y  hom unity a  MkArr {U} (Dom a) (λe{U}. DOWN (IMG x)) = y"
            using MkElem_IMG eq by presburger
          hence "y = x"
            using MkElem_IMG x y by blast
          thus ?thesis by meson
        qed
      qed
    qed

    lemma set_char:
    assumes "ide a"
    shows "set a = UP ` Dom a"
    proof
      show "set a  UP ` Dom a"
      proof
        fix t
        assume "t  set a"
        from this obtain p where p: "«p : unity  a»  t = IMG p"
          using set_def by blast
        have "t = (UP o Map p o DOWN) unity"
          using p IMG_point(2) by blast
        moreover have "(Map p o DOWN) unity  Dom a"
          using p arr_char in_hom_char Dom_terminal terminal_unity
          by (metis (mono_tags, lifting) IntD2 Pi_split_insert_domain o_apply)
        ultimately show "t  UP ` Dom a" by simp
      qed
      show "UP ` Dom a  set a"
      proof
        fix t
        assume "t  UP ` Dom a"
        from this obtain x where x: "x  Dom a  t = UP x" by blast
        let ?p = "MkElem (UP x) a"
        have p: "?p  hom unity a"
          using assms x MkElem_in_hom [of "dom a"] ideD(1-2) by force
        moreover have "IMG ?p = t"
          using p x DOWN_UP IMG_def UP_def
          by (metis (no_types, lifting) Dom.simps(1) Map.simps(1) image_empty
              image_insert image_restrict_eq)
        ultimately show "t  set a" using set_def by blast
      qed
    qed
  
    lemma Map_via_comp:
    assumes "arr f"
    shows "Map f = (λx  Dom f. Map (f  MkElem (UP x) (dom f)) U)"
    proof
      fix x
      have "x  Dom f  Map f x = (λx  Dom f. Map (f  MkElem (UP x) (dom f)) U) x"
        using assms arr_char [of f] IntD1 extensional_arb restrict_apply by fastforce
      moreover have
           "x  Dom f  Map f x = (λx  Dom f. Map (f  MkElem (UP x) (dom f)) U) x"
      proof -
        assume x: "x  Dom f"
        let ?X = "MkElem (UP x) (dom f)"
        have "«?X : unity  dom f»"
          using assms x MkElem_in_hom by auto
        moreover have "Dom ?X = {U}  Map ?X = (λ_  {U}. x)"
          using x by simp
        ultimately have
          "Map (f  MkElem (UP x) (dom f)) = compose {U} (Map f) (λ_  {U}. x)"
          using assms x Map_comp [of "MkElem (UP x) (dom f)" f]
          by (metis (mono_tags, lifting) Cod.simps(1) Dom_dom arr_iff_in_hom seqE seqI')
        thus ?thesis
          using x by (simp add: compose_eq restrict_apply' singletonI)
      qed
      ultimately show "Map f x = (λx  Dom f. Map (f  MkElem (UP x) (dom f)) U) x"
        by auto
    qed

    lemma arr_eqI':
    assumes "par f f'" and "t. «t : unity  dom f»  f  t = f'  t"
    shows "f = f'"
    proof (intro arr_eqI)
      show "arr f" using assms by simp
      show "arr f'" using assms by simp
      show "Dom f = Dom f'"
        using assms by (metis (mono_tags, lifting) Dom_dom)
      show "Cod f = Cod f'"
        using assms by (metis (mono_tags, lifting) Cod_cod)
      show "Map f = Map f'"
      proof
        have 1: "x. x  Dom f  «MkElem (UP x) (dom f) : unity  dom f»"
          using MkElem_in_hom by (metis (mono_tags, lifting) assms(1))
        fix x
        show "Map f x = Map f' x"
          using assms 1 ‹Dom f = Dom f' by (simp add: Map_via_comp)
      qed
    qed

    text ‹
      We need to show that the cardinality constraint on the sets that determine objects
      implies a corresponding constraint on the sets of global elements of those objects.
    ›
    
    lemma card_points_less:
    assumes "ide a"
    shows "|hom unity a| <o 𝔄"
    proof -
      have "bij_betw (λf. Map f U) (hom unity a) (Dom a)"
      proof (intro bij_betwI')
        show "x. x  hom unity a  Map x (DOWN unity)  Dom a"
          using arr_char Dom_terminal terminal_unity in_hom_char by auto
        show "x y. x  hom unity a; y  hom unity a  Map x U = Map y U  x = y"
        proof -
          fix x y
          assume x: "x  hom unity a" and y: "y  hom unity a"
          have 1: "Map x  extensional {U}  Map y  extensional {U}"
            using x y in_hom_char Dom_terminal terminal_unity
            by (metis (mono_tags, lifting) Map_via_comp mem_Collect_eq restrict_extensional)
          show "Map x U = Map y U  x = y"
          proof
            show "x = y  Map x U = Map y U"
              by simp
            show "Map x U = Map y U  x = y"
            proof -
              assume 2: "Map x U = Map y U"
              have "Map x = Map y"
              proof
                fix z
                show "Map x z = Map y z"
                  using 1 2 extensional_arb [of "Map x"] extensional_arb [of "Map y"]
                  by (cases "z = U") auto
              qed
              thus "x = y"
                using x y 1 in_hom_char
                by (intro arr_eqI) auto
            qed
          qed
        qed
        show "y. y  Dom a  x  hom unity a. y = Map x (DOWN unity)"
        proof -
          fix y
          assume y: "y  Dom a"
          let ?x = "MkArr {DOWN unity} (Dom a) (λ_  {U}. y)"
          have "arr ?x"
          proof (intro arr_MkArr)
            show "{U}  {A. |A| <o 𝔄}"
              by (metis (mono_tags, lifting) Dom_terminal ide_char terminal_def terminal_unity)
            show "Dom a  {A. |A| <o 𝔄}"
              using assms ide_char by blast
            show "(λ_  {U}. y)  extensional {U}  ({U}  Dom a)"
              using assms y by blast
          qed
          hence "?x  hom unity a"
            using UP_DOWN UP_def assms cod_MkArr dom_char in_homI terminal_unity by simp
          moreover have "y = Map ?x (DOWN unity)"
            by simp
          ultimately show "x  hom unity a. y = Map x (DOWN unity)"
            by auto
        qed
      qed
      hence "|hom unity a| =o |Dom a|"
        using card_of_ordIsoI by auto
      moreover have "|Dom a| <o 𝔄"
        using assms ide_char by auto
      ultimately show "|hom unity a| <o 𝔄"
        using ordIso_ordLess_trans by auto
    qed

    text‹
      The main result, which establishes the consistency of the set_category› locale
      and provides us with a way of obtaining ``set categories'' at arbitrary types.
›

    theorem is_set_category:
    shows "set_category comp 𝔄"
    proof
      show "img :: 'e setcat.arr  'e setcat.arr. set_category_given_img comp img 𝔄"
      proof
        show "set_category_given_img (comp :: 'e setcat.arr comp) IMG 𝔄"
        proof
          show "Card_order 𝔄  infinite (Field 𝔄 )"
            using cardinal by simp
          show "Univ  {}" using terminal_char by blast
          fix a :: "'e setcat.arr"
          assume a: "ide a"
          show "IMG  hom unity a  Univ" using IMG_point terminal_unity by blast
          show "|hom unity a| <o 𝔄" using a card_points_less by simp
          show "inj_on IMG (hom unity a)" using a inj_IMG terminal_unity by blast
          next
          fix t :: "'e setcat.arr"
          assume t: "terminal t"
          show "t  IMG ` hom unity t"
          proof -
            have "t  set t"
              using t set_char [of t]
              by (metis (mono_tags, lifting) Dom.simps(1) image_insert insertI1 UP_def
                  terminal_char terminal_def)
            thus ?thesis
              using t set_def [of t] by simp
          qed
          next
          fix A :: "'e setcat.arr set"
          assume A: "A  Univ" and 0: "|A| <o 𝔄"
          show "a. ide a  set a = A"
          proof
            let ?a = "MkArr (DOWN ` A) (DOWN ` A) (λx  (DOWN ` A). x)"
            show "ide ?a  set ?a = A"
            proof
              have "|DOWN ` A| <o 𝔄"
                using 0 card_of_image ordLeq_ordLess_trans by blast
              thus 1: "ide ?a"
                using ide_char [of ?a] by simp
              show "set ?a = A"
              proof -
                have 2: "x. x  A  x = UP (DOWN x)"
                  using A UP_DOWN by force
                hence "UP ` DOWN ` A = A"
                  using A UP_DOWN by auto
                thus ?thesis
                  using 1 A set_char [of ?a] by simp
              qed
            qed
          qed
          next
          fix a b :: "'e setcat.arr"
          assume a: "ide a" and b: "ide b" and ab: "set a = set b"
          show "a = b"
            using a b ab set_char inj_UP inj_image_eq_iff dom_char in_homE ide_in_hom
            by (metis (mono_tags, lifting))
          next
          fix f f' :: "'e setcat.arr"
          assume par: "par f f'" and ff': "x. «x : unity  dom f»  f  x = f'  x"
          show "f = f'" using par ff' arr_eqI' by blast
          next
          fix a b :: "'e setcat.arr" and F :: "'e setcat.arr  'e setcat.arr"
          assume a: "ide a" and b: "ide b" and F: "F  hom unity a  hom unity b"
          show "f. «f : a  b»  (x. «x : unity  dom f»  f  x = F x)"
          proof
            let ?f = "MkArr (Dom a) (Dom b) (λx  Dom a. Map (F (MkElem (UP x) a)) U)"
            have 1: "«?f : a  b»"
            proof -
              have "(λx  Dom a. Map (F (MkElem (UP x) a)) U)
                       extensional (Dom a)  (Dom a  Dom b)"
              proof
                show "(λx  Dom a. Map (F (MkElem (UP x) a)) U)  extensional (Dom a)"
                  using a F by simp
                show "(λx  Dom a. Map (F (MkElem (UP x) a)) U)  Dom a  Dom b"
                proof
                  fix x
                  assume x: "x  Dom a"
                  have "MkElem (UP x) a  hom unity a"
                    using x a MkElem_in_hom [of a x] ide_char ideD(1-2) by force
                  hence 1: "F (MkElem (UP x) a)  hom unity b"
                    using F by auto
                  moreover have "Dom (F (MkElem (UP x) a)) = {U}"
                    using 1 MkElem_IMG
                    by (metis (mono_tags, lifting) Dom.simps(1))
                  moreover have "Cod (F (MkElem (UP x) a)) = Dom b"
                    using 1 by (metis (mono_tags, lifting) CollectD in_hom_char)
                  ultimately have "Map (F (MkElem (UP x) a))  {U}  Dom b"
                    using arr_char [of "F (MkElem (UP x) a)"] by blast
                  thus "Map (F (MkElem (UP x) a)) U  Dom b" by blast
                qed
              qed
              hence "«?f : MkIde (Dom a)  MkIde (Dom b)»"
                using a b MkArr_in_hom ide_char by blast
              thus ?thesis
                using a b by simp
            qed
            moreover have "x. «x : unity  dom ?f»  ?f  x = F x"
            proof -
              fix x
              assume x: "«x : unity  dom ?f»"
              have 2: "x = MkElem (IMG x) a"
                using a x 1 MkElem_IMG [of x a]
                by (metis (mono_tags, lifting) in_homE mem_Collect_eq)
              moreover have 5: "Dom x = {U}  Cod x = Dom a 
                                Map x = (λ_  {U}. DOWN (IMG x))"
                using x 2
                by (metis (no_types, lifting) Cod.simps(1) Dom.simps(1) Map.simps(1))
              moreover have "Cod ?f = Dom b" using 1 by simp
              ultimately have
                   3: "?f  x =
                       MkArr {U} (Dom b) (compose {U} (Map ?f) (λ_  {U}. DOWN (IMG x)))"
                using 1 x comp_char [of ?f "MkElem (IMG x) a"]
                by (metis (mono_tags, lifting) in_homE seqI)
              have 4: "compose {U} (Map ?f) (λ_  {U}. DOWN (IMG x)) = Map (F x)"
              proof
                fix y
                have "y  {U} 
                        compose {U} (Map ?f) (λ_  {U}. DOWN (IMG x)) y = Map (F x) y"
                proof -
                  assume y: "y  {U}"
                  have "compose {U} (Map ?f) (λ_  {U}. DOWN (IMG x)) y = undefined"
                    using y compose_def extensional_arb by simp
                  also have "... = Map (F x) y"
                  proof -
                    have 5: "F x  hom unity b" using x F 1 by fastforce
                    hence "Dom (F x) = {U}"
                      by (metis (mono_tags, lifting) "2" CollectD Dom.simps(1) in_hom_char x)
                    thus ?thesis
                      using x y F 5 arr_char [of "F x"] extensional_arb [of "Map (F x)" "{U}" y]
                      by (metis (mono_tags, lifting) CollectD Int_iff in_hom_char)
                  qed
                  ultimately show ?thesis by auto
                qed
                moreover have
                    "y  {U} 
                       compose {U} (Map ?f) (λ_  {U}. DOWN (IMG x)) y = Map (F x) y"
                proof -
                  assume y: "y  {U}"
                  have "compose {U} (Map ?f) (λ_  {U}. DOWN (IMG x)) y =
                        Map ?f (DOWN (IMG x))"
                    using y by (simp add: compose_eq restrict_apply')
                  also have "... = (λx. Map (F (MkElem (UP x) a)) U) (DOWN (IMG x))"
                  proof -
                    have "DOWN (IMG x)  Dom a"
                      using x y a 5 arr_char in_homE restrict_apply by force
                    thus ?thesis
                      using restrict_apply by simp
                  qed
                  also have "... = Map (F x) y"
                    using x y 1 2 MkElem_IMG [of x a] by simp
                  finally show
                      "compose {U} (Map ?f) (λ_  {U}. DOWN (IMG x)) y = Map (F x) y"
                    by auto
                qed
                ultimately show
                    "compose {U} (Map ?f) (λ_  {U}. DOWN (IMG x)) y = Map (F x) y"
                  by auto
              qed
              show "?f  x = F x"
              proof (intro arr_eqI)
                have 5: "?f  x  hom unity b" using 1 x by blast
                have 6: "F x  hom unity b"
                  using x F 1
                  by (metis (mono_tags, lifting) PiE in_homE mem_Collect_eq)
                show "arr (comp ?f x)" using 5 by blast
                show "arr (F x)" using 6 by blast
                show "Dom (comp ?f x) = Dom (F x)"
                  using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
                show "Cod (comp ?f x) = Cod (F x)"
                  using 5 6 by (metis (mono_tags, lifting) CollectD in_hom_char)
                show "Map (comp ?f x) = Map (F x)"
                  using 3 4 by simp
              qed
            qed
            thus "«?f : a  b»  (x. «x : unity  dom ?f»  comp ?f x = F x)"
              using 1 by blast
          qed
        qed
      qed
    qed

    textSetCat› can be viewed as a concrete set category over its own element type
      @{typ 'a}, using @{term UP} as the required injection from @{typ 'a} to the universe
      of SetCat›.
›

    corollary is_concrete_set_category:
    shows "concrete_set_category comp 𝔄 UNIV UP"
    proof -
      interpret S: set_category comp 𝔄 using is_set_category by auto
      show ?thesis
      proof
        show 1: "UP  UNIV  S.Univ"
          using UP_def terminal_char by force
        show "inj_on UP UNIV"
          using inj_UP by blast
      qed
    qed

    text‹
      As a consequence of the categoricity of the set_category› axioms,
      if @{term S} interprets set_category›, and if @{term φ} is a bijection between
      the universe of @{term S} and the elements of type @{typ 'a}, then @{term S} is isomorphic
      to the category setcat› of @{typ 'a} sets and functions between them constructed here.
›

    corollary set_category_iso_SetCat:
    fixes S :: "'s comp" and φ :: "'s  'e"
    assumes "set_category S 𝔄"
    and "bij_betw φ (Collect (category.terminal S)) UNIV"
    shows "Φ. invertible_functor S (comp :: 'e setcat.arr comp) Φ
                  (m. set_category.incl S 𝔄 m  set_category.incl comp 𝔄 (Φ m))"
    proof -
      interpret S: set_category S using assms by auto
      let  = "inv_into S.Univ φ"
      have "bij_betw (UP o φ) S.Univ (Collect terminal)"
      proof (intro bij_betwI)
        show "UP o φ  S.Univ  Collect terminal"
          using assms(2) UP_mapsto by auto
        show " o DOWN  Collect terminal  S.Univ"
        proof
          fix x :: "'e setcat.arr"
          assume x: "x  Univ"
          show "(inv_into S.Univ φ  DOWN) x  S.Univ"
            using x assms(2) bij_betw_def comp_apply inv_into_into
            by (metis UNIV_I)
        qed
        fix t
        assume "t  S.Univ"
        thus "( o DOWN) ((UP o φ) t) = t"
          using assms(2) bij_betw_inv_into_left
          by (metis comp_apply DOWN_UP)
        next
        fix t' :: "'e setcat.arr"
        assume "t'  Collect terminal"
        thus "(UP o φ) (( o DOWN) t') = t'"
          using assms(2) by (simp add: bij_betw_def f_inv_into_f)
      qed
      thus ?thesis
        using assms(1) set_category_is_categorical [of S 𝔄 comp "UP o φ"] is_set_category
        by auto
    qed

  end

  sublocale setcat  set_category comp 𝔄
    using is_set_category by simp
  sublocale setcat  concrete_set_category comp 𝔄 UNIV UP
    using is_concrete_set_category by simp

  text‹
    By using a large enough cardinal, we can effectively eliminate the cardinality constraint
    on the sets that determine objects and thereby obtain a set category that is replete.
    This is the normal use case, which we want to streamline as much as possible,
    so it is useful to introduce a special locale for this purpose.
  ›

  locale replete_setcat =
  fixes dummy :: 'e
  begin

    interpretation SC: setcat dummy
                         ‹cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)
    proof
      show "Card_order (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)) 
            infinite (Field (cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)))"
      by (metis Card_order_cmax Field_natLeq cardSuc_Card_order cardSuc_finite
          card_of_Card_order finite_cmax infinite_UNIV_char_0 natLeq_Card_order)
    qed

    text‹
      We don't want to expose the concrete details of the construction used to obtain
      the interpretation SC›; instead, we want any facts proved about it to be derived
      solely from the assumptions of the @{locale set_category} locales.
      So we create another level of definitions here.
    ›

    definition comp
    where "comp  SC.comp"

    definition UP
    where "UP  SC.UP"

    definition DOWN
    where "DOWN  SC.DOWN"

    sublocale set_category comp ‹cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq)
      using SC.is_set_category comp_def by simp

    sublocale concrete_set_category comp
                ‹cardSuc (cmax (card_of (UNIV :: 'e setcat.arr set)) natLeq) UNIV UP
      using SC.is_concrete_set_category comp_def UP_def by simp

    sublocale replete_set_category comp ..

    lemma UP_mapsto:
    shows "UP  UNIV  Univ"
      using SC.UP_mapsto
      by (simp add: UP_def comp_def)

    lemma DOWN_mapsto:
    shows "DOWN  Univ  UNIV"
      by auto

    lemma DOWN_UP [simp]:
    shows "DOWN (UP x) = x"
      by (simp add: DOWN_def UP_def)

    lemma UP_DOWN [simp]:
    assumes "t  Univ"
    shows "UP (DOWN t) = t"
      using assms DOWN_def UP_def
      by (simp add: DOWN_def UP_def comp_def)

    lemma inj_UP:
    shows "inj UP"
      by (metis DOWN_UP injI)

    lemma bij_UP:
    shows "bij_betw UP UNIV Univ"
      by (metis SC.bij_UP UP_def comp_def)

  end

end

Theory ProductCategory

(*  Title:       ProductCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter ProductCategory

theory ProductCategory
imports Category EpiMonoIso
begin

  text‹
    This theory defines the product of two categories @{term C1} and @{term C2},
    which is the category @{term C} whose arrows are ordered pairs consisting of an
    arrow of @{term C1} and an arrow of @{term C2}, with composition defined
    componentwise.  As the ordered pair (C1.null, C2.null)› is available
    to serve as C.null›, we may directly identify the arrows of the product
    category @{term C} with ordered pairs, leaving the type of arrows of @{term C}
    transparent.
›

  locale product_category =
    C1: category C1 +
    C2: category C2
  for C1 :: "'a1 comp"      (infixr "1" 55)
  and C2 :: "'a2 comp"      (infixr "2" 55)
  begin

    type_synonym ('aa1, 'aa2) arr = "'aa1 * 'aa2"

    notation C1.in_hom      ("«_ : _ 1 _»")
    notation C2.in_hom      ("«_ : _ 2 _»")

    abbreviation (input) Null :: "('a1, 'a2) arr"
    where "Null  (C1.null, C2.null)"

    abbreviation (input) Arr :: "('a1, 'a2) arr  bool"
    where "Arr f  C1.arr (fst f)  C2.arr (snd f)"

    abbreviation (input) Ide :: "('a1, 'a2) arr  bool"
    where "Ide f  C1.ide (fst f)  C2.ide (snd f)"

    abbreviation (input) Dom :: "('a1, 'a2) arr  ('a1, 'a2) arr"
    where "Dom f  (if Arr f then (C1.dom (fst f), C2.dom (snd f)) else Null)"

    abbreviation (input) Cod :: "('a1, 'a2) arr  ('a1, 'a2) arr"
    where "Cod f  (if Arr f then (C1.cod (fst f), C2.cod (snd f)) else Null)"

    definition comp :: "('a1, 'a2) arr  ('a1, 'a2) arr  ('a1, 'a2) arr"
    where "comp g f = (if Arr f  Arr g  Cod f = Dom g then
                         (C1 (fst g) (fst f), C2 (snd g) (snd f))
                       else Null)"

    notation comp      (infixr "" 55)

    lemma not_Arr_Null:
    shows "¬Arr Null"
      by simp

    interpretation partial_magma comp
    proof
      show "∃!n. f. n  f = n  f  n = n"
      proof
        let ?P = "λn. f. n  f = n  f  n = n"
        show 1: "?P Null" using comp_def not_Arr_Null by metis
        thus "n. f. n  f = n  f  n = n  n = Null" by metis
      qed
    qed

    notation in_hom  ("«_ : _  _»")

    lemma null_char [simp]:
    shows "null = Null"
    proof -
      let ?P = "λn. f. n  f = n  f  n = n"
      have "?P Null" using comp_def not_Arr_Null by metis
      thus ?thesis
        unfolding null_def using the1_equality [of ?P Null] ex_un_null by blast
    qed

    lemma ide_Ide:
    assumes "Ide a"
    shows "ide a"
      unfolding ide_def comp_def null_char
      using assms C1.not_arr_null C1.ide_in_hom C1.comp_arr_dom C1.comp_cod_arr
            C2.comp_arr_dom C2.comp_cod_arr
      by auto

    lemma has_domain_char:
    shows "domains f  {}  Arr f"
    proof
      show "domains f  {}  Arr f"
        unfolding domains_def comp_def null_char by (auto; metis)
      assume f: "Arr f"
      show "domains f  {}"
      proof -
        have "ide (Dom f)  comp f (Dom f)  null"
          using f comp_def ide_Ide C1.comp_arr_dom C1.arr_dom_iff_arr C2.arr_dom_iff_arr
          by auto
        thus ?thesis using domains_def by blast
      qed
    qed

    lemma has_codomain_char:
    shows "codomains f  {}  Arr f"
    proof
      show "codomains f  {}  Arr f"
        unfolding codomains_def comp_def null_char by (auto; metis)
      assume f: "Arr f"
      show "codomains f  {}"
      proof -
        have "ide (Cod f)  comp (Cod f) f  null"
          using f comp_def ide_Ide C1.comp_cod_arr C1.arr_cod_iff_arr C2.arr_cod_iff_arr
          by auto
        thus ?thesis using codomains_def by blast
      qed
    qed

    lemma arr_char [iff]:
    shows "arr f  Arr f"
      using has_domain_char has_codomain_char arr_def by simp

    lemma arrI [intro]:
    assumes "C1.arr f1" and "C2.arr f2"
    shows "arr (f1, f2)"
      using assms by simp

    lemma arrE:
    assumes "arr f"
    and "C1.arr (fst f)  C2.arr (snd f)  T"
    shows "T"
      using assms by auto

    lemma seqI [intro]:
    assumes "C1.seq g1 f1  C2.seq g2 f2"
    shows "seq (g1, g2) (f1, f2)"
      using assms comp_def by auto

    lemma seqE [elim]:
    assumes "seq g f"
    and "C1.seq (fst g) (fst f)  C2.seq (snd g) (snd f)  T"
    shows "T"
      using assms comp_def
      by (metis (no_types, lifting) C1.seqI C2.seqI Pair_inject not_arr_null null_char)

    lemma seq_char [iff]:
    shows "seq g f  C1.seq (fst g) (fst f)  C2.seq (snd g) (snd f)"
      using comp_def by auto

    lemma Dom_comp:
    assumes "seq g f"
    shows "Dom (g  f) = Dom f"
    proof -
      have "C1.arr (fst f)  C1.arr (fst g)  C1.dom (fst g) = C1.cod (fst f)"
        using assms by blast
      moreover have "C2.arr (snd f)  C2.arr (snd g)  C2.dom (snd g) = C2.cod (snd f)"
        using assms by blast
      ultimately show ?thesis
        by (simp add: comp_def)
    qed

    lemma Cod_comp:
    assumes "seq g f"
    shows "Cod (g  f) = Cod g"
    proof -
      have "C1.arr (fst f)  C1.arr (fst g)  C1.dom (fst g) = C1.cod (fst f)"
        using assms by blast
      moreover have "C2.arr (snd f)  C2.arr (snd g)  C2.dom (snd g) = C2.cod (snd f)"
        using assms by blast
      ultimately show ?thesis
        by (simp add: comp_def)
    qed

    theorem is_category:
    shows "category comp"
    proof
      fix f
      show "(domains f  {}) = (codomains f  {})"
        using has_domain_char has_codomain_char by simp
      fix g
      show "g  f  null  seq g f"
        using comp_def seq_char by (metis C1.seqI C2.seqI Pair_inject null_char)
      fix h
      show "seq h g  seq (h  g) f  seq g f"
        using seq_char
        by (metis category.seqE category.seqI Dom_comp
            product_category_axioms product_category_def fst_conv snd_conv)
      show "seq h (g  f)  seq g f  seq h g"
        using seq_char
        by (metis category.seqE category.seqI Cod_comp
            product_category_axioms product_category_def fst_conv snd_conv)
      show "seq g f  seq h g  seq (h  g) f"
        using seq_char
        by (metis arrE category.seqE category.seqI Dom_comp
            product_category_axioms product_category_def fst_conv snd_conv)
      show "seq g f  seq h g  (h  g)  f = h  g  f"
        using comp_def null_char seq_char C1.comp_assoc C2.comp_assoc
        by (elim seqE C1.seqE C2.seqE, simp)
    qed

    sublocale category comp
      using is_category comp_def by auto

    lemma dom_char:
    shows "dom f = Dom f"
    proof (cases "Arr f")
      show "¬Arr f  dom f = Dom f"
        unfolding dom_def using has_domain_char by auto
      show "Arr f  dom f = Dom f"
        using ide_Ide apply (intro dom_eqI, simp)
        using seq_char comp_def C1.arr_dom_iff_arr C2.arr_dom_iff_arr by auto
    qed

    lemma dom_simp [simp]:
    assumes "arr f"
    shows "dom f = (C1.dom (fst f), C2.dom (snd f))"
      using assms dom_char by auto

    lemma cod_char:
    shows "cod f = Cod f"
    proof (cases "Arr f")
      show "¬Arr f  cod f = Cod f"
        unfolding cod_def using has_codomain_char by auto
      show "Arr f  cod f = Cod f"
        using ide_Ide seqI apply (intro cod_eqI, simp)
        using seq_char comp_def C1.arr_cod_iff_arr C2.arr_cod_iff_arr by auto
    qed

    lemma cod_simp [simp]:
    assumes "arr f"
    shows "cod f = (C1.cod (fst f), C2.cod (snd f))"
      using assms cod_char by auto

    lemma in_homI [intro, simp]:
    assumes "«fst f: fst a 1 fst b»" and "«snd f: snd a 2 snd b»"
    shows "«f: a  b»"
      using assms by fastforce

    lemma in_homE [elim]:
    assumes "«f: a  b»"
    and "«fst f: fst a 1 fst b»  «snd f: snd a 2 snd b»  T"
    shows "T"
      using assms
      by (metis C1.in_homI C2.in_homI arr_char cod_simp dom_simp fst_conv in_homE snd_conv)

    lemma ide_char [iff]:
    shows "ide f  Ide f"
      using ide_in_hom C1.ide_in_hom C2.ide_in_hom by blast

    lemma comp_char:
    shows "g  f = (if C1.arr (C1 (fst g) (fst f))  C2.arr (C2 (snd g) (snd f)) then
                       (C1 (fst g) (fst f), C2 (snd g) (snd f))
                    else Null)"
      using comp_def by auto

    lemma comp_simp [simp]:
    assumes "C1.seq (fst g) (fst f)" and "C2.seq (snd g) (snd f)"
    shows "g  f = (fst g 1 fst f, snd g 2 snd f)"
      using assms comp_char by simp

    lemma iso_char [iff]:
    shows "iso f  C1.iso (fst f)  C2.iso (snd f)"
    proof
      assume f: "iso f"
      obtain g where g: "inverse_arrows f g" using f by auto
      have 1: "ide (g  f)  ide (f  g)"
        using f g by (simp add: inverse_arrows_def)
      have "g  f = (fst g 1 fst f, snd g 2 snd f)  f  g = (fst f 1 fst g, snd f 2 snd g)"
        using 1 comp_char arr_char by (meson ideD(1) seq_char)
      hence "C1.ide (fst g 1 fst f)  C2.ide (snd g 2 snd f) 
             C1.ide (fst f 1 fst g)  C2.ide (snd f 2 snd g)"
        using 1 ide_char by simp
      hence "C1.inverse_arrows (fst f) (fst g)  C2.inverse_arrows (snd f) (snd g)"
        by auto
      thus "C1.iso (fst f)  C2.iso (snd f)" by auto
      next
      assume f: "C1.iso (fst f)  C2.iso (snd f)"
      obtain g1 where g1: "C1.inverse_arrows (fst f) g1" using f by blast
      obtain g2 where g2: "C2.inverse_arrows (snd f) g2" using f by blast
      have "C1.ide (g1 1 fst f)  C2.ide (g2 2 snd f) 
            C1.ide (fst f 1 g1)  C2.ide (snd f 2 g2)"
        using g1 g2 ide_char by force
      hence "inverse_arrows f (g1, g2)"
        using f g1 g2 ide_char comp_char by (intro inverse_arrowsI, auto)
      thus "iso f" by auto
    qed

    lemma isoI [intro, simp]:
    assumes "C1.iso (fst f)" and "C2.iso (snd f)"
    shows "iso f"
      using assms by simp

    lemma isoD:
    assumes "iso f"
    shows "C1.iso (fst f)" and "C2.iso (snd f)"
      using assms by auto

    lemma inv_simp [simp]:
    assumes "iso f"
    shows "inv f = (C1.inv (fst f), C2.inv (snd f))"
    proof -
      have "inverse_arrows f (C1.inv (fst f), C2.inv (snd f))"
      proof
        have 1: "C1.inverse_arrows (fst f) (C1.inv (fst f))"
          using assms iso_char C1.inv_is_inverse by simp
        have 2: "C2.inverse_arrows (snd f) (C2.inv (snd f))"
          using assms iso_char C2.inv_is_inverse by simp
        show "ide ((C1.inv (fst f), C2.inv (snd f))  f)"
          using 1 2 ide_char comp_char by auto
        show "ide (f  (C1.inv (fst f), C2.inv (snd f)))"
          using 1 2 ide_char comp_char by auto
      qed
      thus ?thesis using inverse_unique by auto
    qed

  end

end

Theory NaturalTransformation

(*  Title:       NaturalTransformation
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter NaturalTransformation

theory NaturalTransformation
imports Functor
begin

  section "Definition of a Natural Transformation"
    
  text‹
    As is the case for functors, the ``object-free'' definition of category
    makes it possible to view natural transformations as functions on arrows.
    In particular, a natural transformation between functors
    @{term F} and @{term G} from @{term A} to @{term B} can be represented by
    the map that takes each arrow @{term f} of @{term A} to the diagonal of the
    square in @{term B} corresponding to the transformation of @{term "F f"}
    to @{term "G f"}.  The images of the identities of @{term A} under this
    map are the usual components of the natural transformation.
    This representation exhibits natural transformations as a kind of generalization
    of functors, and in fact we can directly identify functors with identity
    natural transformations.
    However, functors are still necessary to state the defining conditions for
    a natural transformation, as the domain and codomain of a natural transformation
    cannot be recovered from the map on arrows that represents it.

    Like functors, natural transformations preserve arrows and map non-arrows to null.
    Natural transformations also ``preserve'' domain and codomain, but in a more general
    sense than functors. The naturality conditions, which express the two ways of factoring
    the diagonal of a commuting square, are degenerate in the case of an identity transformation.
›

  locale natural_transformation =
    A: category A +
    B: category B + 
    F: "functor" A B F +
    G: "functor" A B G
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and F :: "'a  'b"
  and G :: "'a  'b"
  and τ :: "'a  'b" +
  assumes is_extensional: "¬A.arr f  τ f = B.null"
  and preserves_dom [iff]: "A.arr f  B.dom (τ f) = F (A.dom f)"
  and preserves_cod [iff]: "A.arr f  B.cod (τ f) = G (A.cod f)"
  and is_natural_1 [iff]: "A.arr f  G f B τ (A.dom f) = τ f"
  and is_natural_2 [iff]: "A.arr f  τ (A.cod f) B F f = τ f"
  begin

    lemma naturality:
    assumes "A.arr f"
    shows "τ (A.cod f) B F f = G f B τ (A.dom f)"
      using assms is_natural_1 is_natural_2 by simp

    text‹
      The following fact for natural transformations provides us with the same advantages
      as the corresponding fact for functors.
›

    lemma preserves_reflects_arr [iff]:
    shows "B.arr (τ f)  A.arr f"
      using is_extensional A.arr_cod_iff_arr B.arr_cod_iff_arr preserves_cod by force

    lemma preserves_hom [intro]:
    assumes "«f : a A b»"
    shows "«τ f : F a B G b»"
      using assms
      by (metis A.in_homE B.arr_cod_iff_arr B.in_homI G.preserves_arr G.preserves_cod
          preserves_cod preserves_dom)

    lemma preserves_comp_1:
    assumes "A.seq f' f"
    shows "τ (f' A f) = G f' B τ f"
      using assms
      by (metis A.seqE A.dom_comp B.comp_assoc G.preserves_comp is_natural_1)

    lemma preserves_comp_2:
    assumes "A.seq f' f"
    shows "τ (f' A f) = τ f' B F f"
      using assms
      by (metis A.arr_cod_iff_arr A.cod_comp B.comp_assoc F.preserves_comp is_natural_2)

    text‹
      A natural transformation that also happens to be a functor is equal to
      its own domain and codomain.
›

    lemma functor_implies_equals_dom:
    assumes "functor A B τ"
    shows "F = τ"
    proof
      interpret τ: "functor" A B τ using assms by auto
      fix f
      show "F f = τ f"
        using assms
        by (metis A.dom_cod B.comp_cod_arr F.is_extensional F.preserves_arr F.preserves_cod
            τ.preserves_dom is_extensional is_natural_2 preserves_dom)
    qed

    lemma functor_implies_equals_cod:
    assumes "functor A B τ"
    shows "G = τ"
    proof
      interpret τ: "functor" A B τ using assms by auto
      fix f
      show "G f = τ f"
        using assms
        by (metis A.cod_dom B.comp_arr_dom F.preserves_arr G.is_extensional G.preserves_arr
            G.preserves_dom B.cod_dom functor_implies_equals_dom is_extensional
            is_natural_1 preserves_cod preserves_dom)
    qed
          
  end

  section "Components of a Natural Transformation"

  text‹
    The values taken by a natural transformation on identities are the \emph{components}
    of the transformation.  We have the following basic technique for proving two natural
    transformations equal: show that they have the same components.
›

  lemma eqI:
  assumes "natural_transformation A B F G σ" and "natural_transformation A B F G σ'"
  and "a. partial_magma.ide A a  σ a = σ' a"
  shows "σ = σ'"
  proof -
    interpret A: category A using assms(1) natural_transformation_def by blast
    interpret σ: natural_transformation A B F G σ using assms(1) by auto
    interpret σ': natural_transformation A B F G σ' using assms(2) by auto
    have "f. σ f = σ' f"
      using assms(3) σ.is_natural_2 σ'.is_natural_2 σ.is_extensional σ'.is_extensional A.ide_cod
      by metis
    thus ?thesis by auto
  qed

  text‹
    As equality of natural transformations is determined by equality of components,
    a natural transformation may be uniquely defined by specifying its components.
    The extension to all arrows is given by @{prop is_natural_1} or equivalently
    by @{prop is_natural_2}.
›

  locale transformation_by_components =
    A: category A +
    B: category B + 
    F: "functor" A B F +
    G: "functor" A B G
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and F :: "'a  'b"
  and G :: "'a  'b"
  and t :: "'a  'b" +
  assumes maps_ide_in_hom [intro]: "A.ide a  «t a : F a B G a»"
  and is_natural: "A.arr f  t (A.cod f) B F f = G f B t (A.dom f)"
  begin

    definition map
    where "map f = (if A.arr f then t (A.cod f) B F f else B.null)"

    lemma map_simp_ide [simp]:
    assumes "A.ide a"
    shows "map a = t a"
      using assms map_def B.comp_arr_dom [of "t a"] maps_ide_in_hom by fastforce

    lemma is_natural_transformation:
    shows "natural_transformation A B F G map"
      using map_def is_natural
      apply (unfold_locales, simp_all)
         apply (metis A.ide_dom B.dom_comp B.seqI
                      G.preserves_arr G.preserves_dom B.in_homE maps_ide_in_hom)
        apply (metis A.ide_dom B.arrI B.cod_comp B.in_homE B.seqI
                     G.preserves_arr G.preserves_cod G.preserves_dom maps_ide_in_hom)
       apply (metis A.ide_dom B.comp_arr_dom B.in_homE maps_ide_in_hom)
      by (metis B.comp_assoc A.comp_cod_arr F.preserves_comp)

  end

  sublocale transformation_by_components  natural_transformation A B F G map
    using is_natural_transformation by auto

  lemma transformation_by_components_idem [simp]:
  assumes "natural_transformation A B F G τ"
  shows "transformation_by_components.map A B F τ = τ"
  proof -
    interpret τ: natural_transformation A B F G τ using assms by blast
    interpret τ': transformation_by_components A B F G τ
      by (unfold_locales, auto) 
    show ?thesis
      using assms τ'.map_simp_ide τ'.is_natural_transformation eqI by blast
  qed

  section "Functors as Natural Transformations"

  text‹
    A functor is a special case of a natural transformation, in the sense that the same map
    that defines the functor also defines an identity natural transformation.
›

  lemma functor_is_transformation [simp]:
  assumes "functor A B F"
  shows "natural_transformation A B F F F"
  proof -
    interpret "functor" A B F using assms by auto
    show "natural_transformation A B F F F"
      using is_extensional B.comp_arr_dom B.comp_cod_arr
      by (unfold_locales, simp_all)
  qed

  sublocale "functor"  natural_transformation A B F F F
    by (simp add: functor_axioms)

  section "Constant Natural Transformations"

  text‹
    A constant natural transformation is one whose components are all the same arrow.
›

  locale constant_transformation =
    A: category A +
    B: category B +
    F: constant_functor A B "B.dom g" +
    G: constant_functor A B "B.cod g"
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and g :: 'b +
  assumes value_is_arr: "B.arr g"
  begin

    definition map
    where "map f  if A.arr f then g else B.null"

    lemma map_simp [simp]:
    assumes "A.arr f"
    shows "map f = g"
      using assms map_def by auto

    lemma is_natural_transformation:
    shows "natural_transformation A B F.map G.map map"
      apply unfold_locales
      using map_def value_is_arr B.comp_arr_dom B.comp_cod_arr by auto

    lemma is_functor_if_value_is_ide:
    assumes "B.ide g"
    shows "functor A B map"
      apply unfold_locales using assms map_def by auto

  end

  sublocale constant_transformation  natural_transformation A B F.map G.map map
    using is_natural_transformation by auto

  context constant_transformation
  begin

    lemma equals_dom_if_value_is_ide:
    assumes "B.ide g"
    shows "map = F.map"
      using assms functor_implies_equals_dom is_functor_if_value_is_ide by auto

    lemma equals_cod_if_value_is_ide:
    assumes "B.ide g"
    shows "map = G.map"
      using assms functor_implies_equals_dom is_functor_if_value_is_ide by auto

  end

  section "Vertical Composition"

  text‹
    Vertical composition is a way of composing natural transformations σ: F → G›
    and τ: G → H›, between parallel functors @{term F}, @{term G}, and @{term H}
    to obtain a natural transformation from @{term F} to @{term H}.
    The composite is traditionally denoted by τ o σ›, however in the present
    setting this notation is misleading because it is horizontal composite, rather than
    vertical composite, that coincides with composition of natural transformations as
    functions on arrows.
›

  locale vertical_composite =
    A: category A +
    B: category B +
    F: "functor" A B F +
    G: "functor" A B G +
    H: "functor" A B H +
    σ: natural_transformation A B F G σ +
    τ: natural_transformation A B G H τ
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and F :: "'a  'b"
  and G :: "'a  'b"
  and H :: "'a  'b"
  and σ :: "'a  'b"
  and τ :: "'a  'b"
  begin

    text‹
      Vertical composition takes an arrow @{term "A.in_hom a b f"} to an arrow in
      @{term "B.hom (F a) (G b)"}, which we can obtain by forming either of
      the composites @{term "B (τ b) (σ f)"} or @{term "B (τ f) (σ a)"}, which are
      equal to each other.
›

    definition map
    where "map f = (if A.arr f then τ (A.cod f) B σ f else B.null)"

    lemma map_seq:
    assumes "A.arr f"
    shows "B.seq (τ (A.cod f)) (σ f)"
      using assms by auto

    lemma map_simp_ide:
    assumes "A.ide a"
    shows "map a = τ a B σ a"
      using assms map_def by auto

    lemma map_simp_1:
    assumes "A.arr f"
    shows "map f = τ (A.cod f) B σ f"
      using assms by (simp add: map_def)

    lemma map_simp_2:
    assumes "A.arr f"
    shows "map f = τ f B σ (A.dom f)"
      using assms
      by (metis B.comp_assoc σ.is_natural_2 σ.naturality τ.is_natural_1 τ.naturality map_simp_1)

    lemma is_natural_transformation:
    shows "natural_transformation A B F H map"
      using map_def map_simp_1 map_simp_2 map_seq B.comp_assoc
      apply (unfold_locales, simp_all)
      by (metis B.comp_assoc τ.is_natural_1)

  end

  sublocale vertical_composite  natural_transformation A B F H map
    using is_natural_transformation by auto

  text‹
    Functors are the identities for vertical composition.
›

  lemma vcomp_ide_dom [simp]:
  assumes "natural_transformation A B F G τ"
  shows "vertical_composite.map A B F τ = τ"
    using assms apply (intro eqI)
      apply auto[2]
     apply (meson functor_is_transformation natural_transformation_def vertical_composite.intro
                  vertical_composite.is_natural_transformation)
  proof -
    fix a :: 'a
    have "vertical_composite A B F F G F τ"
      by (meson assms functor_is_transformation natural_transformation.axioms(1-4)
                vertical_composite.intro)
    thus "vertical_composite.map A B F τ a = τ a"
      using assms natural_transformation.is_extensional natural_transformation.is_natural_2
            vertical_composite.map_def
      by fastforce
  qed
    
  lemma vcomp_ide_cod [simp]:
  assumes "natural_transformation A B F G τ"
  shows "vertical_composite.map A B τ G = τ"
    using assms apply (intro eqI)
      apply auto[2]
     apply (meson functor_is_transformation natural_transformation_def vertical_composite.intro
                  vertical_composite.is_natural_transformation)
  proof -
    fix a :: 'a
    assume a: "partial_magma.ide A a"
    interpret Goτ: vertical_composite A B F G G τ G
      by (meson assms functor_is_transformation natural_transformation.axioms(1-4)
                vertical_composite.intro)
    show "vertical_composite.map A B τ G a = τ a"
      using assms a natural_transformation.is_extensional natural_transformation.is_natural_1
            Goτ.map_simp_ide Goτ.B.comp_cod_arr
      by simp
  qed

  text‹
    Vertical composition is associative.
›

  lemma vcomp_assoc [simp]:
  assumes "natural_transformation A B F G ρ"
  and "natural_transformation A B G H σ"
  and "natural_transformation A B H K τ"
  shows "vertical_composite.map A B (vertical_composite.map A B ρ σ) τ
            = vertical_composite.map A B ρ (vertical_composite.map A B σ τ)"
  proof -
    interpret A: category A
      using assms(1) natural_transformation_def functor_def by blast
    interpret B: category B
      using assms(1) natural_transformation_def functor_def by blast
    interpret ρ: natural_transformation A B F G ρ using assms(1) by auto
    interpret σ: natural_transformation A B G H σ using assms(2) by auto
    interpret τ: natural_transformation A B H K τ using assms(3) by auto
    interpret ρσ: vertical_composite A B F G H ρ σ ..
    interpret στ: vertical_composite A B G H K σ τ ..
    interpret ρ_στ: vertical_composite A B F G K ρ στ.map ..
    interpret ρσ_τ: vertical_composite A B F H K ρσ.map τ ..
    show ?thesis
      using ρσ_τ.is_natural_transformation ρ_στ.natural_transformation_axioms
            ρσ.map_simp_ide ρσ_τ.map_simp_ide ρ_στ.map_simp_ide στ.map_simp_ide B.comp_assoc
      by (intro eqI, auto)
  qed

  section "Natural Isomorphisms"

  text‹
    A natural isomorphism is a natural transformation each of whose components
    is an isomorphism.  Equivalently, a natural isomorphism is a natural transformation
    that is invertible with respect to vertical composition.
›

  locale natural_isomorphism = natural_transformation A B F G τ
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and F :: "'a  'b"
  and G :: "'a  'b"
  and τ :: "'a  'b" +
  assumes components_are_iso [simp]: "A.ide a  B.iso (τ a)"
  begin

    lemma inv_naturality:
    assumes "A.arr f"
    shows "F f B B.inv (τ (A.dom f)) = B.inv (τ (A.cod f)) B G f"
      using assms is_natural_1 is_natural_2 components_are_iso B.invert_side_of_triangle
            B.comp_assoc A.ide_cod A.ide_dom preserves_reflects_arr
      by fastforce

    text ‹
      Natural isomorphisms preserve isomorphisms, in the sense that the sides of
      of the naturality square determined by an isomorphism are all isomorphisms,
      so the diagonal is, as well.
›

    lemma preserves_iso:
    assumes "A.iso f"
    shows "B.iso (τ f)"
      using assms
      by (metis A.ide_dom A.iso_is_arr B.isos_compose G.preserves_iso components_are_iso
          is_natural_2 naturality preserves_reflects_arr)

  end

  text ‹
    Since the function that represents a functor is formally identical to the function
    that represents the corresponding identity natural transformation, no additional locale
    is needed for identity natural transformations.  However, an identity natural transformation
    is also a natural isomorphism, so it is useful for @{locale functor} to inherit from the
    @{locale natural_isomorphism} locale.
›

  sublocale "functor"  natural_isomorphism A B F F F
    apply unfold_locales
    using preserves_ide B.ide_is_iso by simp

  definition naturally_isomorphic
  where "naturally_isomorphic A B F G = (τ. natural_isomorphism A B F G τ)"

  lemma naturally_isomorphic_respects_full_functor:
  assumes "naturally_isomorphic A B F G"
  and "full_functor A B F"
  shows "full_functor A B G"
  proof -
    obtain φ where φ: "natural_isomorphism A B F G φ"
      using assms naturally_isomorphic_def by blast
    interpret φ: natural_isomorphism A B F G φ
      using φ by auto
    interpret φ.F: full_functor A B F
      using assms by auto
    write A (infixr "A" 55)
    write B (infixr "B" 55)
    write φ.A.in_hom ("«_ : _ A _»")
    write φ.B.in_hom ("«_ : _ B _»")
    show "full_functor A B G"
    proof
      fix a a' g
      assume a': "φ.A.ide a'" and a: "φ.A.ide a"
      and g: "«g : G a' B G a»"
      show "f. «f : a' A a»  G f = g"
      proof -
        let ?g' = "φ.B.inv (φ a) B g B φ a'"
        have g': "«?g' : F a' B F a»"
          using a a' g φ.preserves_hom φ.components_are_iso φ.B.inv_in_hom by force
        obtain f' where f': "«f' : a' A a»  F f' = ?g'"
          using a a' g' φ.F.is_full [of a a' ?g'] by blast
        moreover have "G f' = g"
        proof -
          have "G f' = φ a B ?g' B φ.B.inv (φ a')"
            using a a' f' φ.naturality [of f'] φ.components_are_iso φ.is_natural_2
            by (metis φ.A.in_homE φ.B.comp_assoc φ.B.invert_side_of_triangle(2)
                φ.preserves_reflects_arr)
          also have "... = (φ a B φ.B.inv (φ a)) B g B φ a' B φ.B.inv (φ a')"
            using φ.B.comp_assoc by auto
          also have "... = g"
            using a a' g φ.B.comp_arr_dom φ.B.comp_cod_arr φ.B.comp_arr_inv
                  φ.B.inv_is_inverse
            by auto
          finally show ?thesis by blast
        qed
        ultimately show ?thesis by auto
      qed
    qed
  qed

  lemma naturally_isomorphic_respects_faithful_functor:
  assumes "naturally_isomorphic A B F G"
  and "faithful_functor A B F"
  shows "faithful_functor A B G"
  proof -
    obtain φ where φ: "natural_isomorphism A B F G φ"
      using assms naturally_isomorphic_def by blast
    interpret φ: natural_isomorphism A B F G φ
      using φ by auto
    interpret φ.F: faithful_functor A B F
      using assms by auto
    show "faithful_functor A B G"
      using φ.naturality φ.components_are_iso φ.B.iso_is_section φ.B.section_is_mono
            φ.B.monoE φ.F.is_faithful φ.is_natural_1 φ.natural_transformation_axioms
            φ.preserves_reflects_arr φ.A.ide_cod
      by (unfold_locales, metis)
  qed

  locale inverse_transformation =
    A: category A +
    B: category B +
    F: "functor" A B F +
    G: "functor" A B G +
    τ: natural_isomorphism A B F G τ
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and F :: "'a  'b"
  and G :: "'a  'b"
  and τ :: "'a  'b"
  begin

    interpretation τ': transformation_by_components A B G F λa. B.inv (τ a)
    proof
      fix f :: 'a
      show "A.ide f  «B.inv (τ f) : G f B F f»"
        using B.inv_in_hom τ.components_are_iso A.ide_in_hom by blast
      show "A.arr f  B.inv (τ (A.cod f)) B G f = F f B B.inv (τ (A.dom f))"
        by (metis A.ide_cod A.ide_dom B.invert_opposite_sides_of_square τ.components_are_iso
            τ.is_natural_2 τ.naturality τ.preserves_reflects_arr)
    qed

    definition map
    where "map = τ'.map"

    lemma map_ide_simp [simp]:
    assumes "A.ide a"
    shows "map a = B.inv (τ a)"
      using assms map_def by fastforce

    lemma map_simp:
    assumes "A.arr f"
    shows "map f = B.inv (τ (A.cod f)) B G f"
      using assms map_def by (simp add: τ'.map_def)

    lemma is_natural_transformation:
    shows "natural_transformation A B G F map"
      by (simp add: τ'.natural_transformation_axioms map_def)

    lemma inverts_components:
    assumes "A.ide a"
    shows "B.inverse_arrows (τ a) (map a)"
      using assms τ.components_are_iso B.ide_is_iso B.inv_is_inverse B.inverse_arrows_def map_def
      by (metis τ'.map_simp_ide)

  end

  sublocale inverse_transformation  natural_transformation A B G F map
    using is_natural_transformation by auto

  sublocale inverse_transformation  natural_isomorphism A B G F map
    by (simp add: natural_isomorphism.intro natural_isomorphism_axioms.intro
        natural_transformation_axioms)

  lemma inverse_inverse_transformation [simp]:
  assumes "natural_isomorphism A B F G τ"
  shows "inverse_transformation.map A B F (inverse_transformation.map A B G τ) = τ"
  proof -
    interpret τ: natural_isomorphism A B F G τ
      using assms by auto
    interpret τ': inverse_transformation A B F G τ ..
    interpret τ'': inverse_transformation A B G F τ'.map ..
    show "τ''.map = τ"
      using τ.natural_transformation_axioms τ''.natural_transformation_axioms   
      by (intro eqI, auto)
  qed

  locale inverse_transformations =
    A: category A +
    B: category B +
    F: "functor" A B F +
    G: "functor" A B G +
    τ: natural_transformation A B F G τ +
    τ': natural_transformation A B G F τ'
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and F :: "'a  'b"
  and G :: "'a  'b"
  and τ :: "'a  'b"
  and τ' :: "'a  'b" +
  assumes inv: "A.ide a  B.inverse_arrows (τ a) (τ' a)"

  sublocale inverse_transformations  natural_isomorphism A B F G τ
    by (meson B.category_axioms τ.natural_transformation_axioms B.iso_def inv
              natural_isomorphism.intro natural_isomorphism_axioms.intro)
  sublocale inverse_transformations  natural_isomorphism A B G F τ'
    by (meson category.inverse_arrows_sym category.iso_def inverse_transformations_axioms
              inverse_transformations_axioms_def inverse_transformations_def
              natural_isomorphism.intro natural_isomorphism_axioms.intro)

  lemma inverse_transformations_sym:
  assumes "inverse_transformations A B F G σ σ'"
  shows "inverse_transformations A B G F σ' σ"
    using assms
    by (simp add: category.inverse_arrows_sym inverse_transformations_axioms_def
                  inverse_transformations_def)

  lemma inverse_transformations_inverse:
  assumes "inverse_transformations A B F G σ σ'"
  shows "vertical_composite.map A B σ σ' = F"
  and "vertical_composite.map A B σ' σ = G"
  proof -
    interpret A: category A
      using assms(1) inverse_transformations_def natural_transformation_def by blast
    interpret inv: inverse_transformations A B F G σ σ' using assms by auto
    interpret σσ': vertical_composite A B F G F σ σ' ..
    show "vertical_composite.map A B σ σ' = F"
      using σσ'.is_natural_transformation inv.F.natural_transformation_axioms
            σσ'.map_simp_ide inv.B.comp_inv_arr inv.inv
      by (intro eqI, simp_all)
    interpret inv': inverse_transformations A B G F σ' σ
      using assms inverse_transformations_sym by blast
    interpret σ'σ: vertical_composite A B G F G σ' σ ..
    show "vertical_composite.map A B σ' σ = G"
      using σ'σ.is_natural_transformation inv.G.natural_transformation_axioms
            σ'σ.map_simp_ide inv'.inv inv.B.comp_inv_arr
      by (intro eqI, simp_all)
  qed

  lemma inverse_transformations_compose:
  assumes "inverse_transformations A B F G σ σ'"
  and "inverse_transformations A B G H τ τ'"
  shows "inverse_transformations A B F H
           (vertical_composite.map A B σ τ) (vertical_composite.map A B τ' σ')"
  proof -
    interpret A: category A using assms(1) inverse_transformations_def by blast
    interpret B: category B using assms(1) inverse_transformations_def by blast
    interpret σσ': inverse_transformations A B F G σ σ' using assms(1) by auto
    interpret ττ': inverse_transformations A B G H τ τ' using assms(2) by auto
    interpret στ: vertical_composite A B F G H σ τ ..
    interpret τ'σ': vertical_composite A B H G F τ' σ' ..
    show ?thesis
      using B.inverse_arrows_compose σσ'.inv στ.map_simp_ide τ'σ'.map_simp_ide ττ'.inv
      by (unfold_locales, auto)
  qed

  lemma vertical_composite_iso_inverse [simp]:
  assumes "natural_isomorphism A B F G τ"
  shows "vertical_composite.map A B τ (inverse_transformation.map A B G τ) = F"
  proof -
    interpret τ: natural_isomorphism A B F G τ using assms by auto
    interpret τ': inverse_transformation A B F G τ ..
    interpret ττ': vertical_composite A B F G F τ τ'.map ..
    show ?thesis
      using ττ'.is_natural_transformation τ.F.natural_transformation_axioms τ'.inverts_components
            τ.B.comp_inv_arr ττ'.map_simp_ide
      by (intro eqI, auto)
  qed

  lemma vertical_composite_inverse_iso [simp]:
  assumes "natural_isomorphism A B F G τ"
  shows "vertical_composite.map A B (inverse_transformation.map A B G τ) τ = G"
  proof -
    interpret τ: natural_isomorphism A B F G τ using assms by auto
    interpret τ': inverse_transformation A B F G τ ..
    interpret τ'τ: vertical_composite A B G F G τ'.map τ ..    
    show ?thesis
      using τ'τ.is_natural_transformation τ.G.natural_transformation_axioms τ'.inverts_components
            τ'τ.map_simp_ide τ.B.comp_arr_inv
      by (intro eqI, auto)
  qed

  lemma natural_isomorphisms_compose:
  assumes "natural_isomorphism A B F G σ" and "natural_isomorphism A B G H τ"
  shows "natural_isomorphism A B F H (vertical_composite.map A B σ τ)"
  proof -
    interpret A: category A
      using assms(1) natural_isomorphism_def natural_transformation_def by blast
    interpret B: category B
      using assms(1) natural_isomorphism_def natural_transformation_def by blast
    interpret σ: natural_isomorphism A B F G σ using assms(1) by auto
    interpret τ: natural_isomorphism A B G H τ using assms(2) by auto
    interpret στ: vertical_composite A B F G H σ τ ..
    interpret natural_isomorphism A B F H στ.map
      using στ.map_simp_ide by (unfold_locales, auto)
    show ?thesis ..
  qed

  lemma naturally_isomorphic_reflexive:
  assumes "functor A B F"
  shows "naturally_isomorphic A B F F"
  proof -
    interpret F: "functor" A B F using assms by auto
    have "natural_isomorphism A B F F F" ..
    thus ?thesis using naturally_isomorphic_def by blast
  qed

  lemma naturally_isomorphic_symmetric:
  assumes "naturally_isomorphic A B F G"
  shows "naturally_isomorphic A B G F"
  proof -
    obtain φ where φ: "natural_isomorphism A B F G φ"
      using assms naturally_isomorphic_def by blast
    interpret φ: natural_isomorphism A B F G φ
      using φ by auto
    interpret ψ: inverse_transformation A B F G φ ..
    have "natural_isomorphism A B G F ψ.map" ..
    thus ?thesis using naturally_isomorphic_def by blast
  qed

  lemma naturally_isomorphic_transitive [trans]:
  assumes "naturally_isomorphic A B F G"
  and "naturally_isomorphic A B G H"
  shows "naturally_isomorphic A B F H"
  proof -
    obtain φ where φ: "natural_isomorphism A B F G φ"
      using assms naturally_isomorphic_def by blast
    interpret φ: natural_isomorphism A B F G φ
      using φ by auto
    obtain ψ where ψ: "natural_isomorphism A B G H ψ"
      using assms naturally_isomorphic_def by blast
    interpret ψ: natural_isomorphism A B G H ψ
      using ψ by auto
    interpret ψφ: vertical_composite A B F G H φ ψ ..
    have "natural_isomorphism A B F H ψφ.map"
      using φ ψ natural_isomorphisms_compose by blast
    thus ?thesis
      using naturally_isomorphic_def by blast
  qed

  section "Horizontal Composition"

  text‹
    Horizontal composition is a way of composing parallel natural transformations
    @{term σ} from @{term F} to @{term G} and @{term τ} from @{term H} to @{term K},
    where functors @{term F} and @{term G} map @{term A} to @{term B} and
    @{term H} and @{term K} map @{term B} to @{term C}, to obtain a natural transformation
    from @{term "H o F"} to @{term "K o G"}.

    Since horizontal composition turns out to coincide with ordinary composition of
    natural transformations as functions, there is little point in defining a cumbersome
    locale for horizontal composite.
›

  lemma horizontal_composite:
  assumes "natural_transformation A B F G σ"
  and "natural_transformation B C H K τ"
  shows "natural_transformation A C (H o F) (K o G) (τ o σ)"
  proof -
    interpret σ: natural_transformation A B F G σ
      using assms(1) by simp
    interpret τ: natural_transformation B C H K τ
      using assms(2) by simp
    interpret HF: composite_functor A B C F H ..
    interpret KG: composite_functor A B C G K ..
    show "natural_transformation A C (H o F) (K o G) (τ o σ)"
      using σ.is_extensional τ.is_extensional
      apply (unfold_locales, auto)
       apply (metis σ.is_natural_1 σ.preserves_reflects_arr τ.preserves_comp_1)
      by (metis σ.is_natural_2 σ.preserves_reflects_arr τ.preserves_comp_2)
  qed

  lemma hcomp_ide_dom [simp]:
  assumes "natural_transformation A B F G τ"
  shows "τ o (identity_functor.map A) = τ"
  proof -
    interpret τ: natural_transformation A B F G τ using assms by auto
    show "τ o τ.A.map = τ"
      using τ.A.map_def τ.is_extensional by fastforce
  qed

  lemma hcomp_ide_cod [simp]:
  assumes "natural_transformation A B F G τ"
  shows "(identity_functor.map B) o τ = τ"
  proof -
    interpret τ: natural_transformation A B F G τ using assms by auto
    show "τ.B.map o τ = τ"
      using τ.B.map_def τ.is_extensional by auto
  qed

  text‹
    Horizontal composition of a functor with a vertical composite.
›

  lemma whisker_right:
  assumes "functor A B F"
  and "natural_transformation B C H K τ" and "natural_transformation B C K L τ'"
  shows "(vertical_composite.map B C τ τ') o F = vertical_composite.map A C (τ o F) (τ' o F)"
  proof -
    interpret F: "functor" A B F using assms(1) by auto
    interpret τ: natural_transformation B C H K τ using assms(2) by auto
    interpret τ': natural_transformation B C K L τ' using assms(3) by auto
    interpret τoF: natural_transformation A C H o F K o F τ o F
      using τ.natural_transformation_axioms F.natural_transformation_axioms
            horizontal_composite
      by blast
    interpret τ'oF: natural_transformation A C K o F L o F τ' o F
      using τ'.natural_transformation_axioms F.natural_transformation_axioms
            horizontal_composite
      by blast
    interpret τ'τ: vertical_composite B C H K L τ τ' ..
    interpret τ'τoF: natural_transformation A C H o F L o F ‹τ'τ.map o F
      using τ'τ.natural_transformation_axioms F.natural_transformation_axioms
            horizontal_composite
      by blast
    interpret τ'oF_τoF: vertical_composite A C H o F K o F L o F τ o F τ' o F ..
    show ?thesis
      using τ'oF_τoF.map_def τ'τ.map_def τ'τoF.is_extensional by auto
  qed

  text‹
    Horizontal composition of a vertical composite with a functor.
›

  lemma whisker_left:
  assumes "functor B C K"
  and "natural_transformation A B F G τ" and "natural_transformation A B G H τ'"
  shows "K o (vertical_composite.map A B τ τ') = vertical_composite.map A C (K o τ) (K o τ')"
  proof -
    interpret K: "functor" B C K using assms(1) by auto
    interpret τ: natural_transformation A B F G τ using assms(2) by auto
    interpret τ': natural_transformation A B G H τ' using assms(3) by auto
    interpret τ'τ: vertical_composite A B F G H τ τ' ..
    interpret Koτ: natural_transformation A C K o F K o G K o τ
      using τ.natural_transformation_axioms K.natural_transformation_axioms
            horizontal_composite
      by blast
    interpret Koτ': natural_transformation A C K o G K o H K o τ'
      using τ'.natural_transformation_axioms K.natural_transformation_axioms
            horizontal_composite
      by blast
    interpret Koτ'τ: natural_transformation A C K o F K o H K o τ'τ.map›
      using τ'τ.natural_transformation_axioms K.natural_transformation_axioms
            horizontal_composite
      by blast
    interpret Koτ'_Koτ: vertical_composite A C K o F K o G K o H K o τ K o τ' ..
    show "K o τ'τ.map = Koτ'_Koτ.map"
      using Koτ'_Koτ.map_def τ'τ.map_def Koτ'τ.is_extensional Koτ'_Koτ.map_simp_1 τ'τ.map_simp_1
      by auto
  qed

  text‹
    The interchange law for horizontal and vertical composition.
›

  lemma interchange:
  assumes "natural_transformation B C F G τ" and "natural_transformation B C G H ν"
  and "natural_transformation C D K L σ" and "natural_transformation C D L M μ"
  shows "vertical_composite.map C D σ μ  vertical_composite.map B C τ ν =
         vertical_composite.map B D (σ  τ) (μ  ν)"
  proof -
    interpret τ: natural_transformation B C F G τ
       using assms(1) by auto
    interpret ν: natural_transformation B C G H ν
       using assms(2) by auto
    interpret σ: natural_transformation C D K L σ
       using assms(3) by auto
    interpret μ: natural_transformation C D L M μ
       using assms(4) by auto
    interpret ντ: vertical_composite B C F G H τ ν ..
    interpret μσ: vertical_composite C D K L M σ μ ..
    interpret σoτ: natural_transformation B D K o F L o G σ o τ
      using σ.natural_transformation_axioms τ.natural_transformation_axioms
            horizontal_composite
      by blast
    interpret μoν: natural_transformation B D L o G M o H μ o ν
      using μ.natural_transformation_axioms ν.natural_transformation_axioms
            horizontal_composite
      by blast
    interpret μσoντ: natural_transformation B D K o F M o H ‹μσ.map o ντ.map›
      using μσ.natural_transformation_axioms ντ.natural_transformation_axioms
            horizontal_composite
      by blast
    interpret μoν_σoτ: vertical_composite B D K o F L o G M o H σ o τ μ o ν ..
    show "μσ.map o ντ.map = μoν_σoτ.map"
    proof (intro eqI)
      show "natural_transformation B D (K  F) (M  H) (μσ.map o ντ.map)" ..
      show "natural_transformation B D (K  F) (M  H) μoν_σoτ.map" ..
      show "a. τ.A.ide a  (μσ.map o ντ.map) a = μoν_σoτ.map a"
      proof -
        fix a
        assume a: "τ.A.ide a"
        have "(μσ.map o ντ.map) a = D (μ (H a)) (σ (C (ν a) (τ a)))"
          using a μσ.map_simp_1 ντ.map_simp_2 by simp
        also have "... = D (μ (ν a)) (σ (τ a))"
          using a
          by (metis (full_types) μ.is_natural_1 μσ.map_simp_1 μσ.preserves_comp_1
              ντ.map_seq ντ.map_simp_1 ντ.preserves_cod σ.B.comp_assoc τ.A.ide_char τ.B.seqE)
        also have "... = μoν_σoτ.map a"
          using a μoν_σoτ.map_simp_ide by simp
        finally show "(μσ.map o ντ.map) a = μoν_σoτ.map a" by blast
      qed
    qed
  qed

  text‹
    A special-case of the interchange law in which two of the natural transformations
    are functors.  It comes up reasonably often, and the reasoning is awkward.
›

  lemma interchange_spc:
  assumes "natural_transformation B C F G σ"
  and "natural_transformation C D H K τ"
  shows "τ  σ = vertical_composite.map B D (H o σ) (τ o G)"
  and "τ  σ = vertical_composite.map B D (τ o F) (K o σ)"
  proof -
    show "τ  σ = vertical_composite.map B D (H  σ) (τ  G)"
    proof -
      have "vertical_composite.map C D H τ  vertical_composite.map B C σ G =
            vertical_composite.map B D (H  σ) (τ  G)"
        by (meson assms functor_is_transformation interchange natural_transformation.axioms(3-4))
      thus ?thesis
        using assms by force
    qed
    show "τ  σ = vertical_composite.map B D (τ  F) (K  σ)"
    proof -
      have "vertical_composite.map C D τ K  vertical_composite.map B C F σ =
            vertical_composite.map B D (τ  F) (K  σ)"
        by (meson assms functor_is_transformation interchange natural_transformation.axioms(3-4))
      thus ?thesis
        using assms by force
    qed
  qed

end


Theory BinaryFunctor

(*  Title:       BinaryFunctor
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter BinaryFunctor

theory BinaryFunctor
imports ProductCategory NaturalTransformation
begin

  text‹
    This theory develops various properties of binary functors, which are functors
    defined on product categories.
›

  locale binary_functor =
    A1: category A1 +
    A2: category A2 +
    B: category B +
    A1xA2: product_category A1 A2 +
    "functor" A1xA2.comp B F
  for A1 :: "'a1 comp"     (infixr "A1" 55)
  and A2 :: "'a2 comp"     (infixr "A2" 55)
  and B :: "'b comp"       (infixr "B" 55)
  and F :: "'a1 * 'a2  'b"
  begin

    notation A1.in_hom     ("«_ : _ A1 _»")
    notation A2.in_hom     ("«_ : _ A2 _»")

  end

  text‹
    A product functor is a binary functor obtained by placing two functors in parallel.
›

  locale product_functor =
    A1: category A1 +
    A2: category A2 +
    B1: category B1 +
    B2: category B2 +
    F1: "functor" A1 B1 F1 +
    F2: "functor" A2 B2 F2 +
    A1xA2: product_category A1 A2 +
    B1xB2: product_category B1 B2
  for A1 :: "'a1 comp"     (infixr "A1" 55)
  and A2 :: "'a2 comp"     (infixr "A2" 55)
  and B1 :: "'b1 comp"     (infixr "B1" 55)
  and B2 :: "'b2 comp"     (infixr "B2" 55)
  and F1 :: "'a1  'b1"
  and F2 :: "'a2  'b2"
  begin

    notation A1xA2.comp    (infixr "A1xA2" 55)
    notation B1xB2.comp    (infixr "B1xB2" 55)
    notation A1.in_hom     ("«_ : _ A1 _»")
    notation A2.in_hom     ("«_ : _ A2 _»")
    notation B1.in_hom     ("«_ : _ B1 _»")
    notation B2.in_hom     ("«_ : _ B2 _»")
    notation A1xA2.in_hom  ("«_ : _ A1xA2 _»")
    notation B1xB2.in_hom  ("«_ : _ B1xB2 _»")

    definition map
    where "map f = (if A1.arr (fst f)  A2.arr (snd f)
                    then (F1 (fst f), F2 (snd f)) else B1xB2.null)"

    lemma map_simp [simp]:
    assumes "A1xA2.arr f"
    shows "map f = (F1 (fst f), F2 (snd f))"
      using assms map_def by simp

    lemma is_functor:
    shows "functor A1xA2.comp B1xB2.comp map"
      using B1xB2.dom_char B1xB2.cod_char
      apply (unfold_locales)
      using map_def A1.arr_dom_iff_arr A1.arr_cod_iff_arr A2.arr_dom_iff_arr A2.arr_cod_iff_arr
          apply auto[4]
      using A1xA2.seqE map_simp by fastforce

  end

  sublocale product_functor  "functor" A1xA2.comp B1xB2.comp map
    using is_functor by auto
  sublocale product_functor  binary_functor A1 A2 B1xB2.comp map ..

  text‹
    A symmetry functor is a binary functor that exchanges its two arguments.
›

  locale symmetry_functor =
  A1: category A1 +
  A2: category A2 +
  A1xA2: product_category A1 A2 +
  A2xA1: product_category A2 A1
  for A1 :: "'a1 comp"     (infixr "A1" 55)
  and A2 :: "'a2 comp"     (infixr "A2" 55)
  begin

    notation A1xA2.comp    (infixr "A1xA2" 55)
    notation A2xA1.comp    (infixr "A2xA1" 55)
    notation A1xA2.in_hom  ("«_ : _ A1xA2 _»")
    notation A2xA1.in_hom  ("«_ : _ A2xA1 _»")

    definition map :: "'a1 * 'a2  'a2 * 'a1"
    where "map f = (if A1xA2.arr f then (snd f, fst f) else A2xA1.null)"

    lemma map_simp [simp]:
    assumes "A1xA2.arr f"
    shows "map f = (snd f, fst f)"
      using assms map_def by meson

    lemma is_functor:
    shows "functor A1xA2.comp A2xA1.comp map"
      using map_def A1.arr_dom_iff_arr A1.arr_cod_iff_arr A2.arr_dom_iff_arr A2.arr_cod_iff_arr
      apply (unfold_locales)
          apply auto[4]
      by force

  end

  sublocale symmetry_functor  "functor" A1xA2.comp A2xA1.comp map
    using is_functor by auto
  sublocale symmetry_functor  binary_functor A1 A2 A2xA1.comp map ..

  context binary_functor
  begin

    abbreviation sym
    where "sym  (λf. F (snd f, fst f))"

    lemma sym_is_binary_functor:
    shows "binary_functor A2 A1 B sym"
    proof -
      interpret A2xA1: product_category A2 A1 ..
      interpret S: symmetry_functor A2 A1 ..
      interpret SF: composite_functor A2xA1.comp A1xA2.comp B S.map F ..
      have "binary_functor A2 A1 B (F o S.map)" ..
      moreover have "F o S.map = (λf. F (snd f, fst f))"
        using is_extensional SF.is_extensional S.map_def by fastforce
      ultimately show ?thesis using sym_def by auto
    qed

    text‹
      Fixing one or the other argument of a binary functor to be an identity
      yields a functor of the other argument.
›

    lemma fixing_ide_gives_functor_1:
    assumes "A1.ide a1"
    shows "functor A2 B (λf2. F (a1, f2))"
      using assms
      apply unfold_locales
      using is_extensional
          apply auto[4]
      by (metis A1.ideD(1) A1.comp_ide_self A1xA2.comp_simp A1xA2.seq_char fst_conv
          preserves_comp_2 snd_conv)

    lemma fixing_ide_gives_functor_2:
    assumes "A2.ide a2"
    shows "functor A1 B (λf1. F (f1, a2))"
      using assms
      apply (unfold_locales)
      using is_extensional
          apply auto[4]
      by (metis A1xA2.comp_simp A1xA2.seq_char A2.ideD(1) A2.comp_ide_self fst_conv
          preserves_comp_2 snd_conv)

    text‹
      Fixing one or the other argument of a binary functor to be an arrow
      yields a natural transformation.
›

    lemma fixing_arr_gives_natural_transformation_1:
    assumes "A1.arr f1"
    shows "natural_transformation A2 B (λf2. F (A1.dom f1, f2)) (λf2. F (A1.cod f1, f2))
                                       (λf2. F (f1, f2))"
    proof -
      let ?Fdom = "λf2. F (A1.dom f1, f2)"
      interpret Fdom: "functor" A2 B ?Fdom using assms fixing_ide_gives_functor_1 by auto
      let ?Fcod = "λf2. F (A1.cod f1, f2)"
      interpret Fcod: "functor" A2 B ?Fcod using assms fixing_ide_gives_functor_1 by auto
      let  = "λf2. F (f1, f2)"
      show "natural_transformation A2 B ?Fdom ?Fcod "
        using assms
        apply unfold_locales
        using is_extensional
            apply auto[3]
        using A1xA2.arr_char preserves_comp A1.comp_cod_arr A1xA2.comp_char A2.comp_arr_dom
         apply (metis fst_conv snd_conv)
        using A1xA2.arr_char preserves_comp A2.comp_cod_arr A1xA2.comp_char A1.comp_arr_dom
        by (metis fst_conv snd_conv)
    qed

    lemma fixing_arr_gives_natural_transformation_2:
    assumes "A2.arr f2"
    shows "natural_transformation A1 B (λf1. F (f1, A2.dom f2)) (λf1. F (f1, A2.cod f2))
                                       (λf1. F (f1, f2))"
    proof -
      interpret F': binary_functor A2 A1 B sym
        using assms(1) sym_is_binary_functor by auto
      have "natural_transformation A1 B (λf1. sym (A2.dom f2, f1)) (λf1. sym (A2.cod f2, f1))
                                        (λf1. sym (f2, f1))"
        using assms F'.fixing_arr_gives_natural_transformation_1 by fast
      thus ?thesis by simp
    qed

    text‹
      Fixing one or the other argument of a binary functor to be a composite arrow
      yields a natural transformation that is a vertical composite.
›

    lemma preserves_comp_1:
    assumes "A1.seq f1' f1"
    shows "(λf2. F (f1' A1 f1, f2)) =
                 vertical_composite.map A2 B (λf2. F (f1, f2)) (λf2. F (f1', f2))"
    proof -
      interpret τ: natural_transformation A2 B
                     λf2. F (A1.dom f1, f2) λf2. F (A1.cod f1, f2) λf2. F (f1, f2)
        using assms fixing_arr_gives_natural_transformation_1 by blast
      interpret τ': natural_transformation A2 B
                     λf2. F (A1.cod f1, f2) λf2. F (A1.cod f1', f2) λf2. F (f1', f2)
        using assms fixing_arr_gives_natural_transformation_1 A1.seqE by metis
      interpret τ'oτ: vertical_composite A2 B
                        λf2. F (A1.dom f1, f2) λf2. F (A1.cod f1, f2) λf2. F (A1.cod f1', f2)
                        λf2. F (f1, f2) λf2. F (f1', f2) ..
      show "(λf2. F (f1' A1 f1, f2)) = τ'oτ.map"
      proof
        fix f2
        have "¬A2.arr f2  F (f1' A1 f1, f2) = τ'oτ.map f2"
          using τ'oτ.is_extensional is_extensional by simp
        moreover have "A2.arr f2  F (f1' A1 f1, f2) = τ'oτ.map f2"
        proof -
          assume f2: "A2.arr f2"
          have "F (f1' A1 f1, f2) = B (F (f1', f2)) (F (f1, A2.dom f2))"
            using assms f2 preserves_comp A1xA2.arr_char A1xA2.comp_char A2.comp_arr_dom
            by (metis fst_conv snd_conv)
          also have "... = τ'oτ.map f2"
            using f2 τ'oτ.map_simp_2 by simp
          finally show "F (f1' A1 f1, f2) = τ'oτ.map f2" by auto
        qed
        ultimately show "F (f1' A1 f1, f2) = τ'oτ.map f2" by blast
      qed
    qed

    lemma preserves_comp_2:
    assumes "A2.seq f2' f2"
    shows "(λf1. F (f1, f2' A2 f2)) =
                 vertical_composite.map A1 B (λf1. F (f1, f2)) (λf1. F (f1, f2'))"
    proof -
      interpret F': binary_functor A2 A1 B sym
        using assms(1) sym_is_binary_functor by auto
      have "(λf1. sym (f2' A2 f2, f1)) =
                 vertical_composite.map A1 B (λf1. sym (f2, f1)) (λf1. sym (f2', f1))"
        using assms F'.preserves_comp_1 by fastforce
      thus ?thesis by simp
    qed

  end

  text‹
    A binary functor transformation is a natural transformation between binary functors.
    We need a certain property of such transformations; namely, that if one or the
    other argument is fixed to be an identity, the result is a natural transformation.
›

  locale binary_functor_transformation =
    A1: category A1 +
    A2: category A2 +
    B: category B +
    A1xA2: product_category A1 A2 +
    F: binary_functor A1 A2 B F +
    G: binary_functor A1 A2 B G +
    natural_transformation A1xA2.comp B F G τ
  for A1 :: "'a1 comp"     (infixr "A1" 55)
  and A2 :: "'a2 comp"     (infixr "A2" 55)
  and B :: "'b comp"       (infixr "B" 55)
  and F :: "'a1 * 'a2  'b"
  and G :: "'a1 * 'a2  'b"
  and τ :: "'a1 * 'a2  'b"
  begin

    notation A1xA2.comp    (infixr "A1xA2" 55)
    notation A1xA2.in_hom  ("«_ : _ A1xA2 _»")

    lemma fixing_ide_gives_natural_transformation_1:
    assumes "A1.ide a1"
    shows "natural_transformation A2 B (λf2. F (a1, f2)) (λf2. G (a1, f2)) (λf2. τ (a1, f2))"
    proof -
      interpret Fa1: "functor" A2 B λf2. F (a1, f2)
        using assms F.fixing_ide_gives_functor_1 by simp
      interpret Ga1: "functor" A2 B λf2. G (a1, f2)
        using assms "G.fixing_ide_gives_functor_1" by simp
      show ?thesis
        using assms is_extensional is_natural_1 is_natural_2
        apply (unfold_locales, auto)
         apply (metis A1.ide_char)
        by (metis A1.ide_char)
    qed

    lemma fixing_ide_gives_natural_transformation_2:
    assumes "A2.ide a2"
    shows "natural_transformation A1 B (λf1. F (f1, a2)) (λf1. G (f1, a2)) (λf1. τ (f1, a2))"
    proof -
      interpret Fa2: "functor" A1 B λf1. F (f1, a2)
        using assms F.fixing_ide_gives_functor_2 by simp
      interpret Ga2: "functor" A1 B λf1. G (f1, a2)
        using assms "G.fixing_ide_gives_functor_2" by simp
      show ?thesis
        using assms is_extensional is_natural_1 is_natural_2
        apply (unfold_locales, auto)
         apply (metis A2.ide_char)
        by (metis A2.ide_char)
    qed

  end

end

Theory FunctorCategory

(*  Title:       FunctorCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter FunctorCategory

theory FunctorCategory
imports ConcreteCategory BinaryFunctor
begin

  text‹
    The functor category [A, B]› is the category whose objects are functors
    from @{term A} to @{term B} and whose arrows correspond to natural transformations
    between these functors.
›

  section "Construction"

  text‹
    Since the arrows of a functor category cannot (in the context of the present development)
    be directly identified with natural transformations, but rather only with natural
    transformations that have been equipped with their domain and codomain functors,
    and since there is no natural value to serve as @{term null},
    we use the general-purpose construction given by @{locale concrete_category} to define
    this category.
›

  locale functor_category =
    A: category A +
    B: category B
  for A :: "'a comp"     (infixr "A" 55)
  and B :: "'b comp"     (infixr "B" 55)
  begin

    notation A.in_hom    ("«_ : _ A _»")
    notation B.in_hom    ("«_ : _ B _»")

    type_synonym ('aa, 'bb) arr = "('aa  'bb, 'aa  'bb) concrete_category.arr"

    sublocale concrete_category ‹Collect (functor A B)
      λF G. Collect (natural_transformation A B F G) λF. F
      λF G H τ σ. vertical_composite.map A B σ τ
      using vcomp_assoc
      apply (unfold_locales, simp_all)
    proof -
      fix F G H σ τ
      assume F: "functor (⋅A) (⋅B) F"
      assume G: "functor (⋅A) (⋅B) G"
      assume H: "functor (⋅A) (⋅B) H"
      assume σ: "natural_transformation (⋅A) (⋅B) F G σ"
      assume τ: "natural_transformation (⋅A) (⋅B) G H τ"
      interpret F: "functor" A B F using F by simp
      interpret G: "functor" A B G using G by simp
      interpret H: "functor" A B H using H by simp
      interpret σ: natural_transformation A B F G σ
        using σ by simp
      interpret τ: natural_transformation A B G H τ
        using τ by simp
      interpret τσ: vertical_composite A B F G H σ τ
        ..
      show "natural_transformation (⋅A) (⋅B) F H (vertical_composite.map (⋅A) (⋅B) σ τ)"
        using τσ.map_def τσ.is_natural_transformation by simp
    qed

    abbreviation comp      (infixr "" 55)
    where "comp  COMP"
    notation in_hom        ("«_ : _  _»")

    lemma arrI [intro]:
    assumes "f  null" and "natural_transformation A B (Dom f) (Cod f) (Map f)"
    shows "arr f"
      using assms arr_char null_char
      by (simp add: natural_transformation_def)

    lemma arrE [elim]:
    assumes "arr f"
    and "f  null  natural_transformation A B (Dom f) (Cod f) (Map f)  T"
    shows T
      using assms arr_char null_char by simp

    lemma arr_MkArr [iff]:
    shows "arr (MkArr F G τ)  natural_transformation A B F G τ"
      using arr_char null_char arr_MkArr natural_transformation_def by fastforce

    lemma ide_char [iff]:
    shows "ide t  t  null  functor A B (Map t)  Dom t = Map t  Cod t = Map t"
      using ide_char null_char by fastforce

  end

  section "Additional Properties"

  text‹
    In this section some additional facts are proved, which make it easier to
    work with the @{term "functor_category"} locale.
›

  context functor_category
  begin

    lemma Map_comp [simp]:
    assumes "seq t' t" and "A.seq a' a"
    shows "Map (t'  t) (a' A a) = Map t' a' B Map t a"
    proof -
      interpret t: natural_transformation A B ‹Dom t ‹Cod t ‹Map t
        using assms(1) arr_char seq_char by blast
      interpret t': natural_transformation A B ‹Cod t ‹Cod t' ‹Map t'
        using assms(1) arr_char seq_char by force 
      interpret t'ot: vertical_composite A B ‹Dom t ‹Cod t ‹Cod t' ‹Map t ‹Map t' ..
      show ?thesis
      proof -
        have "Map (t'  t) = t'ot.map"
          using assms(1) seq_char t'ot.natural_transformation_axioms by simp
        thus ?thesis
          using assms(2) t'ot.map_simp_2 t'.preserves_comp_2 B.comp_assoc by auto
      qed
    qed

    lemma Map_comp':
    assumes "seq t' t"
    shows "Map (t'  t) = vertical_composite.map A B (Map t) (Map t')"
    proof -
      interpret t: natural_transformation A B ‹Dom t ‹Cod t ‹Map t
        using assms(1) arr_char seq_char by blast
      interpret t': natural_transformation A B ‹Cod t ‹Cod t' ‹Map t'
        using assms(1) arr_char seq_char by force 
      interpret t'ot: vertical_composite A B ‹Dom t ‹Cod t ‹Cod t' ‹Map t ‹Map t' ..
      show ?thesis
        using assms(1) seq_char t'ot.natural_transformation_axioms by simp
    qed

    lemma MkArr_eqI [intro]:
    assumes "arr (MkArr F G τ)"
    and "F = F'" and "G = G'" and "τ = τ'"
    shows "MkArr F G τ = MkArr F' G' τ'"
      using assms arr_eqI by simp

    lemma MkArr_eqI' [intro]:
    assumes "arr (MkArr F G τ)" and "τ = τ'"
    shows "MkArr F G τ = MkArr F G τ'"
      using assms arr_eqI by simp

    lemma iso_char [iff]:
    shows "iso t  t  null  natural_isomorphism A B (Dom t) (Cod t) (Map t)"
    proof
      assume t: "iso t"
      show "t  null  natural_isomorphism A B (Dom t) (Cod t) (Map t)"
      proof
        show "t  null" using t arr_char iso_is_arr by auto
        from t obtain t' where t': "inverse_arrows t t'" by blast
        interpret τ: natural_transformation A B ‹Dom t ‹Cod t ‹Map t
          using t arr_char iso_is_arr by auto
        interpret τ': natural_transformation A B ‹Cod t ‹Dom t ‹Map t'
          using t' arr_char dom_char seq_char
          by (metis arrE ide_compE inverse_arrowsE)
        interpret τ'oτ: vertical_composite A B ‹Dom t ‹Cod t ‹Dom t ‹Map t ‹Map t' ..
        interpret τoτ': vertical_composite A B ‹Cod t ‹Dom t ‹Cod t ‹Map t' ‹Map t ..
        show "natural_isomorphism A B (Dom t) (Cod t) (Map t)"
        proof
          fix a
          assume a: "A.ide a"
          show "B.iso (Map t a)"
          proof
            have 1: "τ'oτ.map = Dom t  τoτ'.map = Cod t"
              using t t'
              by (metis (no_types, lifting) Map_dom concrete_category.Map_comp
                  concrete_category_axioms ide_compE inverse_arrowsE seq_char)
            show "B.inverse_arrows (Map t a) (Map t' a)"
              using a 1 τoτ'.map_simp_ide τ'oτ.map_simp_ide τ.F.preserves_ide τ.G.preserves_ide
              by auto
          qed
        qed
      qed
      next
      assume t: "t  null  natural_isomorphism A B (Dom t) (Cod t) (Map t)"
      show "iso t"
      proof
        interpret τ: natural_isomorphism A B ‹Dom t ‹Cod t ‹Map t
          using t by auto
        interpret τ': inverse_transformation A B ‹Dom t ‹Cod t ‹Map t ..
        have 1: "vertical_composite.map A B (Map t) τ'.map = Dom t 
                 vertical_composite.map A B τ'.map (Map t) = Cod t"
          using τ.natural_isomorphism_axioms vertical_composite_inverse_iso
                vertical_composite_iso_inverse
          by blast
        show "inverse_arrows t (MkArr (Cod t) (Dom t) (τ'.map))"
        proof
          show 2: "ide (MkArr (Cod t) (Dom t) τ'.map  t)"
            using t 1
            by (metis (no_types, lifting) MkArr_Map MkIde_Dom τ'.natural_transformation_axioms
                τ.natural_transformation_axioms arrI arr_MkArr comp_MkArr ide_dom)
          show "ide (t  MkArr (Cod t) (Dom t) τ'.map)"
            using t 1 2
            by (metis Dom.simps(1) Map.simps(1) τ.natural_transformation_axioms arrI
                cod_char cod_comp comp_char ide_char' ide_compE)
        qed
      qed
    qed

  end

  section "Evaluation Functor"

  text‹
    This section defines the evaluation map that applies an arrow of the functor
    category [A, B]› to an arrow of @{term A} to obtain an arrow of @{term B}
    and shows that it is functorial.
›

  locale evaluation_functor =
    A: category A +
    B: category B +
    A_B: functor_category A B +
    A_BxA: product_category A_B.comp A
  for A :: "'a comp"          (infixr "A" 55)
  and B :: "'b comp"          (infixr "B" 55)
  begin

    notation A_B.comp         (infixr "[A,B]" 55)
    notation A_BxA.comp       (infixr "[A,B]xA" 55)
    notation A_B.in_hom       ("«_ : _ [A,B] _»")
    notation A_BxA.in_hom     ("«_ : _ [A,B]xA _»")

    definition map
    where "map Fg  if A_BxA.arr Fg then A_B.Map (fst Fg) (snd Fg) else B.null"

    lemma map_simp:
    assumes "A_BxA.arr Fg"
    shows "map Fg = A_B.Map(fst Fg) (snd Fg)"
      using assms map_def by auto

    lemma is_functor:
    shows "functor A_BxA.comp B map"
    proof
      show "Fg. ¬ A_BxA.arr Fg  map Fg = B.null"
        using map_def by auto
      fix Fg
      assume Fg: "A_BxA.arr Fg"
      let ?F = "fst Fg" and ?g = "snd Fg"
      have F: "A_B.arr ?F" using Fg by auto
      have g: "A.arr ?g" using Fg by auto
      have DomF: "A_B.Dom ?F = A_B.Map (A_B.dom ?F)" using F by simp
      have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)" using F by simp
      interpret F: natural_transformation A B ‹A_B.Dom ?F ‹A_B.Cod ?F ‹A_B.Map ?F
        using Fg A_B.arr_char [of ?F] by blast
      show "B.arr (map Fg)" using Fg map_def by auto
      show "B.dom (map Fg) = map (A_BxA.dom Fg)"
        using g Fg map_def DomF
        by (metis (no_types, lifting) A_BxA.arr_dom A_BxA.dom_simp F.preserves_dom
            fst_conv snd_conv)
      show "B.cod (map Fg) = map (A_BxA.cod Fg)"
        using g Fg map_def CodF
        by (metis (no_types, lifting) A_BxA.arr_cod A_BxA.cod_simp F.preserves_cod
            fst_conv snd_conv)
      next
      fix Fg Fg'
      assume 1: "A_BxA.seq Fg' Fg"
      let ?F = "fst Fg" and ?g = "snd Fg"
      let ?F' = "fst Fg'" and ?g' = "snd Fg'"
      have F': "A_B.arr ?F'" using 1 A_BxA.seqE by blast
      have CodF: "A_B.Cod ?F = A_B.Map (A_B.cod ?F)"
        using 1 by (metis A_B.Map_cod A_B.seqE A_BxA.seqE)
      have DomF': "A_B.Dom ?F' = A_B.Map (A_B.dom ?F')"
        using F' by simp
      have seq_F'F: "A_B.seq ?F' ?F" using 1 by blast
      have seq_g'g: "A.seq ?g' ?g" using 1 by blast
      interpret F: natural_transformation A B ‹A_B.Dom ?F ‹A_B.Cod ?F ‹A_B.Map ?F
        using 1 A_B.arr_char by blast
      interpret F': natural_transformation A B ‹A_B.Cod ?F ‹A_B.Cod ?F' ‹A_B.Map ?F'
        using 1 A_B.arr_char seq_F'F CodF DomF' A_B.seqE
        by (metis mem_Collect_eq)
      interpret F'oF: vertical_composite A B ‹A_B.Dom ?F ‹A_B.Cod ?F ‹A_B.Cod ?F'
                                             ‹A_B.Map ?F ‹A_B.Map ?F' ..
      show "map (Fg' [A,B]xA Fg) = map Fg' B map Fg"
        unfolding map_def
        using 1 seq_F'F seq_g'g by auto
    qed

  end

  sublocale evaluation_functor  "functor" A_BxA.comp B map
    using is_functor by auto
  sublocale evaluation_functor  binary_functor A_B.comp A B map ..

  section "Currying"

  text‹
    This section defines the notion of currying of a natural transformation
    between binary functors, to obtain a natural transformation between
    functors into a functor category, along with the inverse operation of uncurrying.
    We have only proved here what is needed to establish the results
    in theory Limit› about limits in functor categories and have not
    attempted to fully develop the functoriality and naturality properties of
    these notions.
›

  locale currying =
  A1: category A1 +
  A2: category A2 +
  B: category B
  for A1 :: "'a1 comp"           (infixr "A1" 55)
  and A2 :: "'a2 comp"           (infixr "A2" 55)
  and B :: "'b comp"             (infixr "B" 55)
  begin

    interpretation A1xA2: product_category A1 A2 ..
    interpretation A2_B: functor_category A2 B ..
    interpretation A2_BxA2: product_category A2_B.comp A2 ..
    interpretation E: evaluation_functor A2 B ..

    notation A1xA2.comp          (infixr "A1xA2" 55)
    notation A2_B.comp           (infixr "[A2,B]" 55)
    notation A2_BxA2.comp        (infixr "[A2,B]xA2" 55)
    notation A1xA2.in_hom        ("«_ : _ A1xA2 _»")
    notation A2_B.in_hom         ("«_ : _ [A2,B] _»")
    notation A2_BxA2.in_hom      ("«_ : _ [A2,B]xA2 _»")

    text‹
      A proper definition for @{term curry} requires that it be parametrized by
      binary functors @{term F} and @{term G} that are the domain and codomain
      of the natural transformations to which it is being applied.
      Similar parameters are not needed in the case of @{term uncurry}.
›

    definition curry :: "('a1 × 'a2  'b)  ('a1 × 'a2  'b)  ('a1 × 'a2  'b)
                            'a1  ('a2, 'b) A2_B.arr"
    where "curry F G τ f1 = (if A1.arr f1 then
                               A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
                                          (λf2. τ (f1, f2))
                             else A2_B.null)"

    definition uncurry :: "('a1  ('a2, 'b) A2_B.arr)  'a1 × 'a2  'b"
    where "uncurry τ f  if A1xA2.arr f then E.map (τ (fst f), snd f) else B.null"

    lemma curry_simp:
    assumes "A1.arr f1"
    shows "curry F G τ f1 = A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
                                       (λf2. τ (f1, f2))"
      using assms curry_def by auto

    lemma uncurry_simp:
    assumes "A1xA2.arr f"
    shows "uncurry τ f = E.map (τ (fst f), snd f)"
      using assms uncurry_def by auto

    lemma curry_in_hom:
    assumes f1: "A1.arr f1"
    and "natural_transformation A1xA2.comp B F G τ"
    shows "«curry F G τ f1 : curry F F F (A1.dom f1) [A2,B] curry G G G (A1.cod f1)»"
    proof -
      interpret τ: natural_transformation A1xA2.comp B F G τ using assms by auto
      show ?thesis
      proof -
        interpret F_dom_f1: "functor" A2 B λf2. F (A1.dom f1, f2)
          using f1 τ.F.is_extensional apply (unfold_locales, simp_all)
          by (metis A1.arr_dom A1.comp_arr_dom A1.dom_dom A1xA2.comp_simp A1xA2.seqI
              τ.F.preserves_comp_2 fst_conv snd_conv)
        interpret G_cod_f1: "functor" A2 B λf2. G (A1.cod f1, f2)
          using f1 τ.G.is_extensional A1.arr_cod_iff_arr
          apply (unfold_locales, simp_all)
          by (metis A1.comp_arr_dom A1.dom_cod A1xA2.comp_simp A1xA2.seqI
              τ.G.preserves_comp fst_conv snd_conv)
        have "natural_transformation A2 B (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
                                          (λf2. τ (f1, f2))"
          using f1 τ.is_extensional apply (unfold_locales, simp_all)
        proof -
          fix f2
          assume f2: "A2.arr f2"
          show "G (A1.cod f1, f2) B τ (f1, A2.dom f2) = τ (f1, f2)"
            using f1 f2 τ.preserves_comp_1 [of "(A1.cod f1, f2)" "(f1, A2.dom f2)"]
                  A1.comp_cod_arr A2.comp_arr_dom
            by simp
          show "τ (f1, A2.cod f2) B F (A1.dom f1, f2) = τ (f1, f2)"
            using f1 f2 τ.preserves_comp_2 [of "(f1, A2.cod f2)" "(A1.dom f1, f2)"]
                  A1.comp_arr_dom A2.comp_cod_arr
            by simp
        qed
        thus ?thesis
          using f1 curry_simp by auto
      qed
    qed

    lemma curry_preserves_functors:
    assumes "functor A1xA2.comp B F"
    shows "functor A1 A2_B.comp (curry F F F)"
    proof -
      interpret F: "functor" A1xA2.comp B F using assms by auto
      interpret F: binary_functor A1 A2 B F ..
      show ?thesis
        using curry_def F.fixing_arr_gives_natural_transformation_1
              A2_B.comp_char F.preserves_comp_1 curry_simp A2_B.seq_char
        apply unfold_locales by auto
    qed

    lemma curry_preserves_transformations:
    assumes "natural_transformation A1xA2.comp B F G τ"
    shows "natural_transformation A1 A2_B.comp (curry F F F) (curry G G G) (curry F G τ)"
    proof -
      interpret τ: natural_transformation A1xA2.comp B F G τ using assms by auto
      interpret τ: binary_functor_transformation A1 A2 B F G τ ..
      interpret curry_F: "functor" A1 A2_B.comp ‹curry F F F
        using curry_preserves_functors τ.F.functor_axioms by simp
      interpret curry_G: "functor" A1 A2_B.comp ‹curry G G G
        using curry_preserves_functors τ.G.functor_axioms by simp
      show ?thesis
      proof
        show "f2. ¬ A1.arr f2  curry F G τ f2 = A2_B.null"
          using curry_def by simp
        fix f1
        assume f1: "A1.arr f1"
        show "A2_B.dom (curry F G τ f1) = curry F F F (A1.dom f1)"
          using assms f1 curry_in_hom by blast
        show "A2_B.cod (curry F G τ f1) = curry G G G (A1.cod f1)"
          using assms f1 curry_in_hom by blast
        show "curry G G G f1 [A2,B] curry F G τ (A1.dom f1) = curry F G τ f1"
        proof -
          interpret τ_dom_f1: natural_transformation A2 B λf2. F (A1.dom f1, f2)
                                λf2. G (A1.dom f1, f2) λf2. τ (A1.dom f1, f2)
            using assms f1 curry_in_hom A1.ide_dom τ.fixing_ide_gives_natural_transformation_1
            by blast
          interpret G_f1: natural_transformation A2 B
                                λf2. G (A1.dom f1, f2) λf2. G (A1.cod f1, f2) λf2. G (f1, f2)
            using f1 τ.G.fixing_arr_gives_natural_transformation_1 by simp
          interpret G_f1oτ_dom_f1: vertical_composite A2 B
                                     λf2. F (A1.dom f1, f2) λf2. G (A1.dom f1, f2)
                                     λf2. G (A1.cod f1, f2)
                                     λf2. τ (A1.dom f1, f2) λf2. G (f1, f2) ..
          have "curry G G G f1 [A2,B] curry F G τ (A1.dom f1)
                  = A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2)) G_f1oτ_dom_f1.map"
          proof -
            have "A2_B.seq (curry G G G f1) (curry F G τ (A1.dom f1))"
              using f1 curry_in_hom [of "A1.dom f1"] τ.natural_transformation_axioms by force
            thus ?thesis
              using f1 curry_simp A2_B.comp_char [of "curry G G G f1" "curry F G τ (A1.dom f1)"]
              by simp
          qed
          also have "... = A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
                                      (λf2. τ (f1, f2))"
          proof (intro A2_B.MkArr_eqI)
            show "(λf2. F (A1.dom f1, f2)) = (λf2. F (A1.dom f1, f2))" by simp
            show "(λf2. G (A1.cod f1, f2)) = (λf2. G (A1.cod f1, f2))" by simp
            show "A2_B.arr (A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
                                       G_f1oτ_dom_f1.map)"
              using G_f1oτ_dom_f1.natural_transformation_axioms by blast
            show "G_f1oτ_dom_f1.map = (λf2. τ (f1, f2))"
            proof
              fix f2
              have "¬A2.arr f2  G_f1oτ_dom_f1.map f2 = (λf2. τ (f1, f2)) f2"
                using f1 G_f1oτ_dom_f1.is_extensional τ.is_extensional by simp
              moreover have "A2.arr f2  G_f1oτ_dom_f1.map f2 = (λf2. τ (f1, f2)) f2"
              proof -
                interpret τ_f1: natural_transformation A2 B λf2. F (A1.dom f1, f2)
                                  λf2. G (A1.cod f1, f2) λf2. τ (f1, f2)
                  using assms f1 curry_in_hom [of f1] curry_simp by auto
                fix f2
                assume f2: "A2.arr f2"
                show "G_f1oτ_dom_f1.map f2 = (λf2. τ (f1, f2)) f2"
                  using f1 f2 G_f1oτ_dom_f1.map_simp_2 B.comp_assoc τ.is_natural_1
                  by fastforce
              qed
              ultimately show "G_f1oτ_dom_f1.map f2 = (λf2. τ (f1, f2)) f2" by blast
            qed
          qed
          also have "... = curry F G τ f1" using f1 curry_def by simp
          finally show ?thesis by blast
        qed
        show "curry F G τ (A1.cod f1) [A2,B] curry F F F f1 = curry F G τ f1"
        proof -
          interpret τ_cod_f1: natural_transformation A2 B λf2. F (A1.cod f1, f2)
                                λf2. G (A1.cod f1, f2) λf2. τ (A1.cod f1, f2)
            using assms f1 curry_in_hom A1.ide_cod τ.fixing_ide_gives_natural_transformation_1
            by blast
          interpret F_f1: natural_transformation A2 B
                                λf2. F (A1.dom f1, f2) λf2. F (A1.cod f1, f2) λf2. F (f1, f2)
            using f1 τ.F.fixing_arr_gives_natural_transformation_1 by simp
          interpret τ_cod_f1oF_f1: vertical_composite A2 B
                                     λf2. F (A1.dom f1, f2) λf2. F (A1.cod f1, f2)
                                     λf2. G (A1.cod f1, f2)
                                     λf2. F (f1, f2) λf2. τ (A1.cod f1, f2) ..
          have "curry F G τ (A1.cod f1) [A2,B] curry F F F f1
                  = A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2)) τ_cod_f1oF_f1.map"
          proof -
            have
                 "curry F F F f1 =
                    A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. F (A1.cod f1, f2))
                               (λf2. F (f1, f2)) 
                  «curry F F F f1 : curry F F F (A1.dom f1) [A2,B] curry F F F (A1.cod f1)»"
              using f1 curry_F.preserves_hom curry_simp by blast
            moreover have
                 "curry F G τ (A1.dom f1) =
                    A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.dom f1, f2))
                               (λf2. τ (A1.dom f1, f2)) 
                    «curry F G τ (A1.cod f1) :
                       curry F F F (A1.cod f1) [A2,B] curry G G G (A1.cod f1)»"
              using assms f1 curry_in_hom [of "A1.cod f1"] curry_def A1.arr_cod_iff_arr by simp
            ultimately show ?thesis
              using f1 curry_def by fastforce
          qed
          also have "... = A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
                                      (λf2. τ (f1, f2))"
          proof (intro A2_B.MkArr_eqI)
            show "(λf2. F (A1.dom f1, f2)) = (λf2. F (A1.dom f1, f2))" by simp
            show "(λf2. G (A1.cod f1, f2)) = (λf2. G (A1.cod f1, f2))" by simp
            show "A2_B.arr (A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. G (A1.cod f1, f2))
                                       τ_cod_f1oF_f1.map)"
              using τ_cod_f1oF_f1.natural_transformation_axioms by blast
            show "τ_cod_f1oF_f1.map = (λf2. τ (f1, f2))"
            proof
              fix f2
              have "¬A2.arr f2  τ_cod_f1oF_f1.map f2 = (λf2. τ (f1, f2)) f2"
                using f1 by (simp add: τ.is_extensional τ_cod_f1oF_f1.is_extensional)
              moreover have "A2.arr f2  τ_cod_f1oF_f1.map f2 = (λf2. τ (f1, f2)) f2"
              proof -
                interpret τ_f1: natural_transformation A2 B λf2. F (A1.dom f1, f2)
                                  λf2. G (A1.cod f1, f2) λf2. τ (f1, f2)
                  using assms f1 curry_in_hom [of f1] curry_simp by auto
                fix f2
                assume f2: "A2.arr f2"
                show "τ_cod_f1oF_f1.map f2 = (λf2. τ (f1, f2)) f2"
                  using f1 f2 τ_cod_f1oF_f1.map_simp_1 B.comp_assoc τ.is_natural_2
                  by fastforce
              qed
              ultimately show "τ_cod_f1oF_f1.map f2 = (λf2. τ (f1, f2)) f2" by blast
            qed
          qed
          also have "... = curry F G τ f1" using f1 curry_def by simp
          finally show ?thesis by blast
        qed
      qed
    qed

    lemma uncurry_preserves_functors:
    assumes "functor A1 A2_B.comp F"
    shows "functor A1xA2.comp B (uncurry F)"
    proof -
      interpret F: "functor" A1 A2_B.comp F using assms by auto
      show ?thesis
        using uncurry_def
        apply (unfold_locales)
            apply auto[4]
      proof -
        fix f g :: "'a1 * 'a2"
        let ?f1 = "fst f"
        let ?f2 = "snd f"
        let ?g1 = "fst g"
        let ?g2 = "snd g"
        assume fg: "A1xA2.seq g f"
        have f: "A1xA2.arr f" using fg A1xA2.seqE by blast
        have f1: "A1.arr ?f1" using f by auto
        have f2: "A2.arr ?f2" using f by auto
        have g: "«g : A1xA2.cod f A1xA2 A1xA2.cod g»"
          using fg A1xA2.dom_char A1xA2.cod_char
          by (elim A1xA2.seqE, intro A1xA2.in_homI, auto)
        let ?g1 = "fst g"
        let ?g2 = "snd g"
        have g1: "«?g1 : A1.cod ?f1 A1 A1.cod ?g1»"
          using f g by (intro A1.in_homI, auto)
        have g2: "«?g2 : A2.cod ?f2 A2 A2.cod ?g2»"
          using f g by (intro A2.in_homI, auto)
        interpret Ff1: natural_transformation A2 B ‹A2_B.Dom (F ?f1) ‹A2_B.Cod (F ?f1)
                                                   ‹A2_B.Map (F ?f1)
          using f A2_B.arr_char [of "F ?f1"] by auto
        interpret Fg1: natural_transformation A2 B ‹A2_B.Cod (F ?f1) ‹A2_B.Cod (F ?g1)
                                                   ‹A2_B.Map (F ?g1)
          using f1 g1 A2_B.arr_char F.preserves_arr
                A2_B.Map_dom [of "F ?g1"] A2_B.Map_cod [of "F ?f1"]
          by fastforce
        interpret Fg1oFf1: vertical_composite A2 B
                              ‹A2_B.Dom (F ?f1) ‹A2_B.Cod (F ?f1) ‹A2_B.Cod (F ?g1)
                              ‹A2_B.Map (F ?f1) ‹A2_B.Map (F ?g1) ..
        show "uncurry F (g A1xA2 f) = uncurry F g B uncurry F f"
          using f1 g1 g2 g2 f g fg E.map_simp uncurry_def by auto
      qed
    qed

    lemma uncurry_preserves_transformations:
    assumes "natural_transformation A1 A2_B.comp F G τ"
    shows "natural_transformation A1xA2.comp B (uncurry F) (uncurry G) (uncurry τ)"
    proof -
      interpret τ: natural_transformation A1 A2_B.comp F G τ using assms by auto
      interpret "functor" A1xA2.comp B ‹uncurry F
        using τ.F.functor_axioms uncurry_preserves_functors by blast
      interpret "functor" A1xA2.comp B ‹uncurry G
        using τ.G.functor_axioms uncurry_preserves_functors by blast
      show ?thesis
      proof
        fix f
        show "¬ A1xA2.arr f  uncurry τ f = B.null"
          using uncurry_def by auto
        assume f: "A1xA2.arr f"
        let ?f1 = "fst f"
        let ?f2 = "snd f"
        show "B.dom (uncurry τ f) = uncurry F (A1xA2.dom f)"
          using f uncurry_def by simp
        show "B.cod (uncurry τ f) = uncurry G (A1xA2.cod f)"
          using f uncurry_def by simp
        show "uncurry G f B uncurry τ (A1xA2.dom f) = uncurry τ f"
          using f uncurry_def τ.is_natural_1 A2_BxA2.seq_char A2.comp_arr_dom
                E.preserves_comp [of "(G (fst f), snd f)" "(τ (A1.dom (fst f)), A2.dom (snd f))"]
          by auto
        show "uncurry τ (A1xA2.cod f) B uncurry F f = uncurry τ f"
        proof -
          have 1: "A1.arr ?f1  A1.arr (fst (A1.cod ?f1, A2.cod ?f2)) 
                   A1.cod ?f1 = A1.dom (fst (A1.cod ?f1, A2.cod ?f2)) 
                   A2.seq (snd (A1.cod ?f1, A2.cod ?f2)) ?f2"
            using f A1.arr_cod_iff_arr A2.arr_cod_iff_arr by auto
          hence 2:
              "?f2 = A2 (snd (τ (fst (A1xA2.cod f)), snd (A1xA2.cod f))) (snd (F ?f1, ?f2))"
            using f A2.comp_cod_arr by simp
          have "A2_B.arr (τ ?f1)" using 1 by force
          thus ?thesis
            unfolding uncurry_def E.map_def
            using f 1 2
            apply simp
            by (metis (no_types, lifting) A2_B.Map_comp ‹A2_B.arr (τ (fst f)) τ.is_natural_2)

        qed
      qed
    qed

    lemma uncurry_curry:
    assumes "natural_transformation A1xA2.comp B F G τ"
    shows "uncurry (curry F G τ) = τ"
    proof
      interpret τ: natural_transformation A1xA2.comp B F G τ using assms by auto
      interpret curry_τ: natural_transformation A1 A2_B.comp ‹curry F F F ‹curry G G G
                                                             ‹curry F G τ
        using assms curry_preserves_transformations by auto
      fix f
      have "¬A1xA2.arr f  uncurry (curry F G τ) f = τ f"
        using curry_def uncurry_def τ.is_extensional by auto
      moreover have "A1xA2.arr f  uncurry (curry F G τ) f = τ f"
      proof -
        assume f: "A1xA2.arr f"
        have 1: "A2_B.Map (curry F G τ (fst f)) (snd f) = τ (fst f, snd f)"
          using f A1xA2.arr_char curry_def by simp
        thus "uncurry (curry F G τ) f = τ f"
          unfolding uncurry_def E.map_def
          using f 1 A1xA2.arr_char [of f] by simp
      qed
      ultimately show "uncurry (curry F G τ) f = τ f" by blast
    qed

    lemma curry_uncurry:
    assumes "functor A1 A2_B.comp F" and "functor A1 A2_B.comp G"
    and "natural_transformation A1 A2_B.comp F G τ"
    shows "curry (uncurry F) (uncurry G) (uncurry τ) = τ"
    proof
      interpret F: "functor" A1 A2_B.comp F using assms(1) by auto
      interpret G: "functor" A1 A2_B.comp G using assms(2) by auto
      interpret τ: natural_transformation A1 A2_B.comp F G τ using assms(3) by auto
      interpret uncurry_F: "functor" A1xA2.comp B ‹uncurry F
        using F.functor_axioms uncurry_preserves_functors by auto
      interpret uncurry_G: "functor" A1xA2.comp B ‹uncurry G
        using G.functor_axioms uncurry_preserves_functors by auto
      fix f1
      have "¬A1.arr f1  curry (uncurry F) (uncurry G) (uncurry τ) f1 = τ f1"
        using curry_def uncurry_def τ.is_extensional by simp
      moreover have "A1.arr f1  curry (uncurry F) (uncurry G) (uncurry τ) f1 = τ f1"
      proof -
        assume f1: "A1.arr f1"
        interpret uncurry_τ:
            natural_transformation A1xA2.comp B ‹uncurry F ‹uncurry G ‹uncurry τ
          using τ.natural_transformation_axioms uncurry_preserves_transformations [of F G τ]
          by simp
        have "curry (uncurry F) (uncurry G) (uncurry τ) f1 =
                A2_B.MkArr (λf2. uncurry F (A1.dom f1, f2)) (λf2. uncurry G (A1.cod f1, f2))
                           (λf2. uncurry τ (f1, f2))"
          using f1 curry_def by simp
        also have "... = A2_B.MkArr (λf2. uncurry F (A1.dom f1, f2))
                                    (λf2. uncurry G (A1.cod f1, f2))
                                    (λf2. E.map (τ f1, f2))"
        proof -
          have "(λf2. uncurry τ (f1, f2)) = (λf2. E.map (τ f1, f2))"
            using f1 uncurry_def E.is_extensional by auto
          thus ?thesis by simp
        qed
        also have "... = τ f1"
        proof -
          have "A2_B.Dom (τ f1) = (λf2. uncurry F (A1.dom f1, f2))"
          proof -
            have "A2_B.Dom (τ f1) = A2_B.Map (A2_B.dom (τ f1))"
              using f1 A2_B.ide_char A2_B.Map_dom A2_B.dom_char by auto
            also have "... = A2_B.Map (F (A1.dom f1))"
              using f1 by simp
            also have "... = (λf2. uncurry F (A1.dom f1, f2))"
            proof
              fix f2
              interpret F_dom_f1: "functor" A2 B ‹A2_B.Map (F (A1.dom f1))
                using f1 A2_B.ide_char F.preserves_ide by simp
              show "A2_B.Map (F (A1.dom f1)) f2 = uncurry F (A1.dom f1, f2)"
                using f1 uncurry_def E.map_simp F_dom_f1.is_extensional by auto
            qed
            finally show ?thesis by auto
          qed
          moreover have "A2_B.Cod (τ f1) = (λf2. uncurry G (A1.cod f1, f2))"
          proof -
            have "A2_B.Cod (τ f1) = A2_B.Map (A2_B.cod (τ f1))"
              using f1 A2_B.ide_char A2_B.Map_cod A2_B.cod_char by auto
            also have "... = A2_B.Map (G (A1.cod f1))"
              using f1 by simp
            also have "... = (λf2. uncurry G (A1.cod f1, f2))"
            proof
              fix f2
              interpret G_cod_f1: "functor" A2 B ‹A2_B.Map (G (A1.cod f1))
                using f1 A2_B.ide_char G.preserves_ide by simp
              show "A2_B.Map (G (A1.cod f1)) f2 = uncurry G (A1.cod f1, f2)"
                using f1 uncurry_def E.map_simp G_cod_f1.is_extensional by auto
            qed
            finally show ?thesis by auto
          qed
          moreover have "A2_B.Map (τ f1) = (λf2. E.map (τ f1, f2))"
          proof
            fix f2
            have "¬A2.arr f2  A2_B.Map (τ f1) f2 = (λf2. E.map (τ f1, f2)) f2"
              using f1 A2_B.arrE τ.preserves_reflects_arr natural_transformation.is_extensional
              by (metis (no_types, lifting) E.fixing_arr_gives_natural_transformation_1)
            moreover have "A2.arr f2  A2_B.Map (τ f1) f2 = (λf2. E.map (τ f1, f2)) f2"
              using f1 E.map_simp by fastforce
            ultimately show "A2_B.Map (τ f1) f2 = (λf2. E.map (τ f1, f2)) f2" by blast
          qed
          ultimately show ?thesis
            using f1 A2_B.MkArr_Map τ.preserves_reflects_arr by metis
        qed
        finally show ?thesis by auto
      qed
      ultimately show "curry (uncurry F) (uncurry G) (uncurry τ) f1 = τ f1" by blast
    qed

  end

  locale curried_functor =
     currying A1 A2 B +
     A1xA2: product_category A1 A2 +
     A2_B: functor_category A2 B +
     F: binary_functor A1 A2 B F
  for A1 :: "'a1 comp"         (infixr "A1" 55)
  and A2 :: "'a2 comp"         (infixr "A2" 55)
  and B :: "'b comp"           (infixr "B" 55)
  and F :: "'a1 * 'a2  'b"
  begin

    notation A1xA2.comp        (infixr "A1xA2" 55)
    notation A2_B.comp         (infixr "[A2,B]" 55)
    notation A1xA2.in_hom      ("«_ : _ A1xA2 _»")
    notation A2_B.in_hom       ("«_ : _ [A2,B] _»")

    definition map
    where "map  curry F F F"

    lemma map_simp [simp]:
    assumes "A1.arr f1"
    shows "map f1 =
           A2_B.MkArr (λf2. F (A1.dom f1, f2)) (λf2. F (A1.cod f1, f2)) (λf2. F (f1, f2))"
      using assms map_def curry_simp by auto

    lemma is_functor:
    shows "functor A1 A2_B.comp map"
      using F.functor_axioms map_def curry_preserves_functors by simp

  end

  sublocale curried_functor  "functor" A1 A2_B.comp map
    using is_functor by auto

  locale curried_functor' =
     A1: category A1 +
     A2: category A2 +
     A1xA2: product_category A1 A2 +
     currying A2 A1 B +
     F: binary_functor A1 A2 B F +
     A1_B: functor_category A1 B
  for A1 :: "'a1 comp"         (infixr "A1" 55)
  and A2 :: "'a2 comp"         (infixr "A2" 55)
  and B :: "'b comp"           (infixr "B" 55)
  and F :: "'a1 * 'a2  'b"
  begin

    notation A1xA2.comp        (infixr "A1xA2" 55)
    notation A1_B.comp         (infixr "[A1,B]" 55)
    notation A1xA2.in_hom      ("«_ : _ A1xA2 _»")
    notation A1_B.in_hom       ("«_ : _ [A1,B] _»")

    definition map
    where "map  curry F.sym F.sym F.sym"

    lemma map_simp [simp]:
    assumes "A2.arr f2"
    shows "map f2 =
           A1_B.MkArr (λf1. F (f1, A2.dom f2)) (λf1. F (f1, A2.cod f2)) (λf1. F (f1, f2))"
      using assms map_def curry_simp by simp

    lemma is_functor:
    shows "functor A2 A1_B.comp map"
    proof -
      interpret A2xA1: product_category A2 A1 ..
      interpret F': binary_functor A2 A1 B F.sym
        using F.sym_is_binary_functor by simp
      have "functor A2xA1.comp B F.sym" ..
      thus ?thesis using map_def curry_preserves_functors by simp
    qed

  end

  sublocale curried_functor'  "functor" A2 A1_B.comp map
    using is_functor by auto

end

Theory Yoneda

(*  Title:       Yoneda
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter Yoneda

theory Yoneda
imports DualCategory SetCat FunctorCategory
begin

  text‹
    This theory defines the notion of a ``hom-functor'' and gives a proof of the Yoneda Lemma.
    In traditional developments of category theory based on set theories such as ZFC,
    hom-functors are normally defined to be functors into the large category \textbf{Set}
    whose objects are of \emph{all} sets and whose arrows are functions between sets.
    However, in HOL there does not exist a single ``type of all sets'', so the notion of
    the category of \emph{all} sets and functions does not make sense.  To work around this,
    we consider a more general setting consisting of a category @{term C} together with
    a set category @{term S} and a function @{term "φ :: 'c * 'c  'c  's"} such that
    whenever @{term b} and @{term a} are objects of C then @{term "φ (b, a)"} maps
    C.hom b a› injectively to S.Univ›.  We show that these data induce
    a binary functor Hom› from Cop×C› to @{term S} in such a way that @{term φ}
    is rendered natural in @{term "(b, a)"}.  The Yoneda lemma is then proved for the
    Yoneda functor determined by Hom›.
›

  section "Hom-Functors"

  text‹
    A hom-functor for a category @{term C} allows us to regard the hom-sets of @{term C}
    as objects of a category @{term S} of sets and functions.  Any description of a
    hom-functor for @{term C} must therefore specify the category @{term S} and provide
    some sort of correspondence between arrows of @{term C} and elements of objects of @{term S}.
    If we are to think of each hom-set C.hom b a› of C› as corresponding
    to an object Hom (b, a)› of @{term S} then at a minimum it ought to be the
    case that the correspondence between arrows and elements is bijective between
    C.hom b a› and Hom (b, a)›.  The hom_functor› locale defined
    below captures this idea by assuming a set category @{term S} and a function @{term φ}
    taking arrows of @{term C} to elements of S.Univ›, such that @{term φ} is injective
    on each set C.hom b a›.  We show that these data induce a functor Hom›
    from Cop×C› to S› in such a way that @{term φ} becomes a natural
    bijection between C.hom b a› and Hom (b, a)›.
›

  locale hom_functor =
    C: category C +
    Cop: dual_category C +
    CopxC: product_category Cop.comp C +
    S: replete_set_category S
  for C :: "'c comp"      (infixr "" 55)
  and S :: "'s comp"      (infixr "S" 55)
  and φ :: "'c * 'c  'c  's" +
  assumes maps_arr_to_Univ: "C.arr f  φ (C.dom f, C.cod f) f  S.Univ"
  and local_inj: " C.ide b; C.ide a   inj_on (φ (b, a)) (C.hom b a)"
  begin

    notation S.in_hom     ("«_ : _ S _»")
    notation CopxC.comp   (infixr "" 55)
    notation CopxC.in_hom ("«_ : _  _»")

    definition set
    where "set ba  φ (fst ba, snd ba) ` C.hom (fst ba) (snd ba)"

    lemma set_subset_Univ:
    assumes "C.ide b" and "C.ide a"
    shows "set (b, a)  S.Univ"
      using assms set_def maps_arr_to_Univ CopxC.ide_char by auto

    definition ψ :: "'c * 'c  's  'c"
    where "ψ ba = inv_into (C.hom (fst ba) (snd ba)) (φ ba)"

    lemma φ_mapsto:
    assumes "C.ide b" and "C.ide a"
    shows "φ (b, a)  C.hom b a  set (b, a)"
      using assms set_def maps_arr_to_Univ by auto

    lemma ψ_mapsto:
    assumes "C.ide b" and "C.ide a"
    shows (b, a)  set (b, a)  C.hom b a"
      using assms set_def ψ_def local_inj by auto

    lemma ψ_φ [simp]:
    assumes "«f : b  a»"
    shows (b, a) (φ (b, a) f) = f"
      using assms local_inj [of b a] ψ_def by fastforce

    lemma φ_ψ [simp]:
    assumes "C.ide b" and "C.ide a"
    and "x  set (b, a)"
    shows "φ (b, a) (ψ (b, a) x) = x"
      using assms set_def local_inj ψ_def by auto

    lemma ψ_img_set:
    assumes "C.ide b" and "C.ide a"
    shows (b, a) ` set (b, a) = C.hom b a"
      using assms ψ_def set_def local_inj by auto

    text‹
      A hom-functor maps each arrow @{term "(g, f)"} of @{term "CopxC"}
      to the arrow of the set category @{term[source=true] S} corresponding to the function
      that takes an arrow @{term h} of @{term C} to the arrow @{term "C f (C h g)"} of @{term C}
      obtained by precomposing with @{term g} and postcomposing with @{term f}.
›

    definition map
    where "map gf =
             (if CopxC.arr gf then
                S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf))
                        (φ (CopxC.cod gf) o (λh. snd gf  h  fst gf) o ψ (CopxC.dom gf))
              else S.null)"

    lemma arr_map:
    assumes "CopxC.arr gf"
    shows "S.arr (map gf)"
    proof -
      have "φ (CopxC.cod gf) o (λh. snd gf  h  fst gf) o ψ (CopxC.dom gf)
               set (CopxC.dom gf)  set (CopxC.cod gf)"
        using assms φ_mapsto [of "fst (CopxC.cod gf)" "snd (CopxC.cod gf)"]
              ψ_mapsto [of "fst (CopxC.dom gf)" "snd (CopxC.dom gf)"]
        by fastforce
      thus ?thesis
        using assms map_def S.arr_mkArr set_subset_Univ S.card_of_leq by simp
    qed

    lemma map_ide [simp]:
    assumes "C.ide b" and "C.ide a"
    shows "map (b, a) = S.mkIde (set (b, a))"
    proof -
      have "map (b, a) = S.mkArr (set (b, a)) (set (b, a))
                                 (φ (b, a) o (λh. a  h  b) o ψ (b, a))"
        using assms map_def by auto
      also have "... = S.mkArr (set (b, a)) (set (b, a)) (λh. h)"
      proof -
        have "S.mkArr (set (b, a)) (set (b, a)) (λh. h) = ..."
          using assms S.arr_mkArr set_subset_Univ set_def C.comp_arr_dom C.comp_cod_arr
                S.card_of_leq S.arr_mkIde
          by (intro S.mkArr_eqI', simp, fastforce)
        thus ?thesis by auto
      qed
      also have "... = S.mkIde (set (b, a))"
        using assms S.mkIde_as_mkArr set_subset_Univ by simp
      finally show ?thesis by auto
    qed

    lemma set_map:
    assumes "C.ide a" and "C.ide b"
    shows "S.set (map (b, a)) = set (b, a)"
      using assms map_ide S.set_mkIde set_subset_Univ by simp

    text‹
      The definition does in fact yield a functor.
›

    interpretation "functor" CopxC.comp S map
    proof
      fix gf
      assume "¬CopxC.arr gf"
      thus "map gf = S.null" using map_def by auto
      next
      fix gf
      assume gf: "CopxC.arr gf"
      thus arr: "S.arr (map gf)" using gf arr_map by blast
      show "S.dom (map gf) = map (CopxC.dom gf)"
      proof -
        have "S.dom (map gf) = S.mkArr (set (CopxC.dom gf)) (set (CopxC.dom gf)) (λx. x)"
          using gf arr_map map_def S.mkIde_as_mkArr S.arr_mkArr by simp
        also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.dom gf))
                                 (φ (CopxC.dom gf) o
                                  (λh. snd (CopxC.dom gf)  h  fst (CopxC.dom gf)) o
                                  ψ (CopxC.dom gf))"
          using gf set_subset_Univ ψ_mapsto map_def set_def S.card_of_leq S.arr_mkIde S.arr_mkArr
          apply (intro S.mkArr_eqI', auto)
          by (metis C.comp_arr_dom C.comp_cod_arr C.in_homE)
        also have "... = map (CopxC.dom gf)"
          using gf map_def C.arr_dom_iff_arr C.arr_cod_iff_arr by simp
        finally show ?thesis by auto
      qed
      show "S.cod (map gf) = map (CopxC.cod gf)"
      proof -
        have "S.cod (map gf) = S.mkArr (set (CopxC.cod gf)) (set (CopxC.cod gf)) (λx. x)"
          using gf map_def arr_map S.mkIde_as_mkArr S.arr_mkArr by simp
        also have "... = S.mkArr (set (CopxC.cod gf)) (set (CopxC.cod gf))
                                 (φ (CopxC.cod gf) o
                                  (λh. snd (CopxC.cod gf)  h  fst (CopxC.cod gf)) o
                                  ψ (CopxC.cod gf))"
          using gf set_subset_Univ ψ_mapsto map_def set_def S.card_of_leq S.arr_mkIde S.arr_mkArr
          apply (intro S.mkArr_eqI', auto)
          by (metis C.comp_arr_dom C.comp_cod_arr C.in_homE)
        also have "... = map (CopxC.cod gf)" using gf map_def by simp
        finally show ?thesis by auto
      qed
      next
      fix gf gf'
      assume gf': "CopxC.seq gf' gf"
      hence seq: "C.arr (fst gf)  C.arr (snd gf)  C.dom (snd gf') = C.cod (snd gf) 
                  C.arr (fst gf')  C.arr (snd gf')  C.dom (fst gf) = C.cod (fst gf')"
        by (elim CopxC.seqE C.seqE, auto)
      have 0: "S.arr (map (CopxC.comp gf' gf))"
        using gf' arr_map by blast
      have 1: "map (gf'  gf) =
                    S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                            (φ (CopxC.cod gf') o (λh. snd (gf'  gf)  h  fst (gf'  gf))
                                               o ψ (CopxC.dom gf))"
        using gf' map_def using CopxC.cod_comp CopxC.dom_comp by auto
      also have "... = S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                               (φ (CopxC.cod gf')  (λh. snd gf'  h  fst gf')  ψ (CopxC.dom gf')
                                
                               (φ (CopxC.cod gf)  (λh. snd gf  h  fst gf)  ψ (CopxC.dom gf)))"
      proof (intro S.mkArr_eqI')
        show "S.arr (S.mkArr (set (CopxC.dom gf)) (set (CopxC.cod gf'))
                             (φ (CopxC.cod gf')  (λh. snd (gf'  gf)  h  fst (gf'  gf))
                                                 ψ (CopxC.dom gf)))"
          using 0 1 by simp
        show "x. x  set (CopxC.dom gf) 
                     (φ (CopxC.cod gf')  (λh. snd (gf'  gf)  h  fst (gf'  gf)) 
                      ψ (CopxC.dom gf)) x =
                     (φ (CopxC.cod gf')  (λh. snd gf'  h  fst gf')  ψ (CopxC.dom gf') 
                      (φ (CopxC.cod gf)  (λh. snd gf  h  fst gf)  ψ (CopxC.dom gf))) x"
        proof -
          fix x
          assume "x  set (CopxC.dom gf)"
          hence x: "x  set (C.cod (fst gf), C.dom (snd gf))"
            using gf' CopxC.seqE by (elim CopxC.seqE, fastforce)
          show "(φ (CopxC.cod gf')  (λh. snd (gf'  gf)  h  fst (gf'  gf)) 
                 ψ (CopxC.dom gf)) x =
                (φ (CopxC.cod gf')  (λh. snd gf'  h  fst gf')  ψ (CopxC.dom gf') 
                 (φ (CopxC.cod gf)  (λh. snd gf  h  fst gf)  ψ (CopxC.dom gf))) x"
          proof -
            have "(φ (CopxC.cod gf') o (λh. snd (gf'  gf)  h  fst (gf'  gf))
                                     o ψ (CopxC.dom gf)) x =
                  φ (CopxC.cod gf') (snd (gf'  gf)  ψ (CopxC.dom gf) x  fst (gf'  gf))"
              by simp
            also have "... = φ (CopxC.cod gf')
                               (((λh. snd gf'  h  fst gf')  ψ (CopxC.dom gf') 
                                 (φ (CopxC.dom gf')  (λh. snd gf  h  fst gf)))
                                (ψ (CopxC.dom gf) x))"
            proof -
              have "C.ide (C.cod (fst gf))  C.ide (C.dom (snd gf))"
                using gf' by (elim CopxC.seqE, auto)
              hence "«ψ (C.cod (fst gf), C.dom (snd gf)) x : C.cod (fst gf)  C.dom (snd gf)»"
                using x ψ_mapsto by auto
              hence "«snd gf  ψ (C.cod (fst gf), C.dom (snd gf)) x  fst gf :
                        C.cod (fst gf')  C.dom (snd gf')»"
                using x seq by auto
              thus ?thesis
                using seq ψ_φ C.comp_assoc by auto
            qed
            also have "... = (φ (CopxC.cod gf')  (λh. snd gf'  h  fst gf')  ψ (CopxC.dom gf') 
                              (φ (CopxC.dom gf')  (λh. snd gf  h  fst gf)  ψ (CopxC.dom gf)))
                              x"
              by auto
            finally show ?thesis using seq by simp
          qed
        qed
      qed
      also have "... = map gf' S map gf"
        using seq gf' map_def arr_map [of gf] arr_map [of gf'] S.comp_mkArr by auto
      finally show "map (gf'  gf) = map gf' S map gf"
        using seq gf' by auto
    qed

    interpretation binary_functor Cop.comp C S map ..

    lemma is_binary_functor:
    shows "binary_functor Cop.comp C S map" ..

  end

  sublocale hom_functor  binary_functor Cop.comp C S map
    using is_binary_functor by auto

  context hom_functor
  begin

    text‹
      The map @{term φ} determines a bijection between @{term "C.hom b a"} and
      @{term "set (b, a)"} which is natural in @{term "(b, a)"}.
›

    lemma φ_local_bij:
    assumes "C.ide b" and "C.ide a"
    shows "bij_betw (φ (b, a)) (C.hom b a) (set (b, a))"
      using assms local_inj inj_on_imp_bij_betw set_def by auto

    lemma φ_natural:
    assumes "C.arr g" and "C.arr f" and "h  C.hom (C.cod g) (C.dom f)"
    shows "φ (C.dom g, C.cod f) (f  h  g) = S.Fun (map (g, f)) (φ (C.cod g, C.dom f) h)"
    proof -
      let ?φh = "φ (C.cod g, C.dom f) h"
      have φh: "?φh  set (C.cod g, C.dom f)"
        using assms φ_mapsto set_def by simp
      have gf: "CopxC.arr (g, f)" using assms by simp
      have "map (g, f) =
               S.mkArr (set (C.cod g, C.dom f)) (set (C.dom g, C.cod f))
                       (φ (C.dom g, C.cod f)  (λh. f  h  g)  ψ (C.cod g, C.dom f))"
        using assms map_def by simp
      moreover have "S.arr (map (g, f))" using gf by simp
      ultimately have
          "S.Fun (map (g, f)) =
               restrict (φ (C.dom g, C.cod f)  (λh. f  h  g)  ψ (C.cod g, C.dom f))
                        (set (C.cod g, C.dom f))"
        using S.Fun_mkArr by simp
      hence "S.Fun (map (g, f)) ?φh =
                (φ (C.dom g, C.cod f)  (λh. f  h  g)  ψ (C.cod g, C.dom f)) ?φh"
        using φh by simp
      also have "... = φ (C.dom g, C.cod f) (f  h  g)"
        using assms(3) by simp
      finally show ?thesis by auto
    qed

    lemma Dom_map:
    assumes "C.arr g" and "C.arr f"
    shows "S.Dom (map (g, f)) = set (C.cod g, C.dom f)"
      using assms map_def preserves_arr S.set_mkIde S.arr_mkArr by auto

    lemma Cod_map:
    assumes "C.arr g" and "C.arr f"
    shows "S.Cod (map (g, f)) = set (C.dom g, C.cod f)"
      using assms map_def preserves_arr S.set_mkIde S.arr_mkArr by auto

    lemma Fun_map:
    assumes "C.arr g" and "C.arr f"
    shows "S.Fun (map (g, f)) =
             restrict (φ (C.dom g, C.cod f) o (λh. f  h  g) o ψ (C.cod g, C.dom f))
                      (set (C.cod g, C.dom f))"
      using assms map_def preserves_arr by force

    lemma map_simp_1:
    assumes "C.arr g" and "C.ide a"
    shows "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                (φ (C.dom g, a) o Cop.comp g o ψ (C.cod g, a))"
    proof -
      have 1: "map (g, a) = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                                    (φ (C.dom g, a) o (λh. a  h  g) o ψ (C.cod g, a))"
        using assms map_def by force
      also have "... = S.mkArr (set (C.cod g, a)) (set (C.dom g, a))
                               (φ (C.dom g, a) o Cop.comp g o ψ (C.cod g, a))"
        using assms 1 preserves_arr [of "(g, a)"] set_def C.in_homI C.comp_cod_arr
        apply (intro S.mkArr_eqI)
           apply simp_all
        by auto
     finally show ?thesis by blast
    qed

    lemma map_simp_2:
    assumes "C.ide b" and "C.arr f"
    shows "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                (φ (b, C.cod f) o C f o ψ (b, C.dom f))"
    proof -
      have 1: "map (b, f) = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                                    (φ (b, C.cod f) o (λh. f  h  b) o ψ (b, C.dom f))"
        using assms map_def by force
      also have "... = S.mkArr (set (b, C.dom f)) (set (b, C.cod f))
                               (φ (b, C.cod f) o C f o ψ (b, C.dom f))"
        using assms 1 preserves_arr [of "(b, f)"] set_def C.in_homI C.comp_arr_dom
        apply (intro S.mkArr_eqI)
           apply simp_all
        by auto
      finally show ?thesis by blast
    qed

  end

  text‹
    Every category @{term C} has a hom-functor: take @{term S} to be the replete set category
    generated by the arrow type 'a› of @{term C} and take @{term "φ (b, a)"} to be the map
    S.UP :: 'a ⇒ 'a SC.arr›.
›

  context category
  begin

    interpretation Cop: dual_category C ..
    interpretation CopxC: product_category Cop.comp C ..
    interpretation S: replete_setcat ‹undefined :: 'a .

    lemma has_hom_functor:
    shows "hom_functor C (S.comp :: 'a setcat.arr comp) (λ_. S.UP)"
    proof
      show "f. arr f  S.UP f  S.Univ"
        using S.UP_mapsto by auto
      show "b a. ide b; ide a  inj_on S.UP (hom b a)"
        by (meson S.inj_UP injD inj_onI)
    qed

  end

  text‹
    The locales set_valued_functor› and set_valued_transformation› provide some
    abbreviations that are convenient when working with functors and natural transformations
    into a set category.
›

  locale set_valued_functor =
    C: category C +
    S: replete_set_category S +
    "functor" C S F
    for C :: "'c comp"
    and S :: "'s comp"
    and F :: "'c  's"
  begin

    abbreviation SET :: "'c  's set"
    where "SET a  S.set (F a)"
    
    abbreviation DOM :: "'c  's set"
    where "DOM f  S.Dom (F f)"
    
    abbreviation COD :: "'c  's set"
    where "COD f  S.Cod (F f)"

    abbreviation FUN :: "'c  's  's"
    where "FUN f  S.Fun (F f)"

  end

  locale set_valued_transformation =
    C: category C +
    S: replete_set_category S +
    F: set_valued_functor C S F +
    G: set_valued_functor C S G +
    natural_transformation C S F G τ
  for C :: "'c comp"
  and S :: "'s comp"
  and F :: "'c  's"
  and G :: "'c  's"
  and τ :: "'c  's"
  begin
  
    abbreviation DOM :: "'c  's set"
    where "DOM f  S.Dom (τ f)"
    
    abbreviation COD :: "'c  's set"
    where "COD f  S.Cod (τ f)"

    abbreviation FUN :: "'c  's  's"
    where "FUN f  S.Fun (τ f)"

  end

  section "Yoneda Functors"
    
  text‹
    A Yoneda functor is the functor from @{term C} to [Cop, S]› obtained by ``currying''
    a hom-functor in its first argument.
›

  locale yoneda_functor =
    C: category C +
    Cop: dual_category C +
    CopxC: product_category Cop.comp C +
    S: replete_set_category S +
    Hom: hom_functor C S φ +
    Cop_S: functor_category Cop.comp S +
    curried_functor' Cop.comp C S Hom.map
  for C :: "'c comp"      (infixr "" 55)
  and S :: "'s comp"      (infixr "S" 55)
  and φ :: "'c * 'c  'c  's"
  begin

    notation Cop_S.in_hom ("«_ : _ [Cop,S] _»")

    abbreviation ψ
    where "ψ  Hom.ψ"

    text‹
      An arrow of the functor category [Cop, S]› consists of a natural transformation
      bundled together with its domain and codomain functors.  However, when considering
      a Yoneda functor from @{term[source=true] C} to [Cop, S]› we generally are only
      interested in the mapping @{term Y} that takes each arrow @{term f} of @{term[source=true] C}
      to the corresponding natural transformation @{term "Y f"}.  The domain and codomain functors
      are then the identity transformations @{term "Y (C.dom f)"} and @{term "Y (C.cod f)"}.
›

    definition Y
    where "Y f  Cop_S.Map (map f)"

    lemma Y_simp [simp]:
    assumes "C.arr f"
    shows "Y f = (λg. Hom.map (g, f))"
      using assms preserves_arr Y_def by simp

    lemma Y_ide_is_functor:
    assumes "C.ide a"
    shows "functor Cop.comp S (Y a)"
      using assms Y_def Hom.fixing_ide_gives_functor_2 by force

    lemma Y_arr_is_transformation:
    assumes "C.arr f"
    shows "natural_transformation Cop.comp S (Y (C.dom f)) (Y (C.cod f)) (Y f)"
      using assms Y_def [of f] map_def Hom.fixing_arr_gives_natural_transformation_2
            preserves_dom preserves_cod by fastforce

    lemma Y_ide_arr [simp]:
    assumes a: "C.ide a" and "«g : b'  b»"
    shows "«Y a g : Hom.map (b, a) S Hom.map (b', a)»"
    and "Y a g =
         S.mkArr (Hom.set (b, a)) (Hom.set (b', a)) (φ (b', a) o Cop.comp g o ψ (b, a))"
      using assms Hom.map_simp_1 by (fastforce, auto)

    lemma Y_arr_ide [simp]:
    assumes "C.ide b" and "«f : a  a'»"
    shows "«Y f b : Hom.map (b, a) S Hom.map (b, a')»"
    and "Y f b = S.mkArr (Hom.set (b, a)) (Hom.set (b, a')) (φ (b, a') o C f o ψ (b, a))"
      using assms apply fastforce
      using assms Hom.map_simp_2 by auto

  end

  locale yoneda_functor_fixed_object =
    yoneda_functor C S φ
  for C :: "'c comp" (infixr "" 55)
  and S :: "'s comp" (infixr "S" 55)
  and φ :: "'c * 'c  'c  's"
  and a :: 'c +
  assumes ide_a: "C.ide a"
  
  sublocale yoneda_functor_fixed_object  "functor" Cop.comp S "(Y a)"
    using ide_a Y_ide_is_functor by auto
  sublocale yoneda_functor_fixed_object  set_valued_functor Cop.comp S "(Y a)" ..

  text‹
    The Yoneda lemma states that, given a category @{term C} and a functor @{term F}
    from @{term Cop} to a set category @{term S}, for each object @{term a} of @{term C},
    the set of natural transformations from the contravariant functor @{term "Y a"}
    to @{term F} is in bijective correspondence with the set F.SET a›
    of elements of @{term "F a"}.

    Explicitly, if @{term e} is an arbitrary element of the set F.SET a›,
    then the functions λx. F.FUN (ψ (b, a) x) e› are the components of a
    natural transformation from @{term "Y a"} to @{term F}.
    Conversely, if @{term τ} is a natural transformation from @{term "Y a"} to @{term F},
    then the component @{term "τ b"} of @{term τ} at an arbitrary object @{term b}
    is completely determined by the single arrow τ.FUN a (φ (a, a) a)))›,
    which is the the element of F.SET a› that corresponds to the image of the
    identity @{term a} under the function τ.FUN a›.
    Then @{term "τ b"} is the arrow from @{term "Y a b"} to @{term "F b"} corresponding
    to the function λx. (F.FUN (ψ (b, a) x) (τ.FUN a (φ (a, a) a)))›
    from S.set (Y a b)› to F.SET b›.
   
    The above expressions look somewhat more complicated than the usual versions due to the
    need to account for the coercions @{term φ} and @{term ψ}.
›

  locale yoneda_lemma =
    C: category C +
    Cop: dual_category C +
    S: replete_set_category S +
    F: set_valued_functor Cop.comp S F +
    yoneda_functor_fixed_object C S φ a
  for C :: "'c comp" (infixr "" 55)
  and S :: "'s comp" (infixr "S" 55)
  and φ :: "'c * 'c  'c  's"
  and F :: "'c  's"
  and a :: 'c
  begin

    text‹
      The mapping that evaluates the component @{term "τ a"} at @{term a} of a
      natural transformation @{term τ} from @{term Y} to @{term F} on the element
      @{term "φ (a, a) a"} of @{term "SET a"}, yielding an element of @{term "F.SET a"}.
›

    definition  :: "('c  's)  's"
    where " τ = S.Fun (τ a) (φ (a, a) a)"

    text‹
      The mapping that takes an element @{term e} of @{term "F.SET a"} and produces
      a map on objects of @{term[source=true] C} whose value at @{term b} is the arrow of
      @{term[source=true] S} corresponding to the function
      @{term "(λx. F.FUN (ψ (b, a) x) e)  Hom.set (b, a)  F.SET b"}.
›

    definition 𝒯o :: "'s  'c  's"
    where "𝒯o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. F.FUN (ψ (b, a) x) e)"

    lemma 𝒯o_e_ide:
    assumes e: "e  S.set (F a)" and b: "C.ide b"
    shows "«𝒯o e b : Y a b S F b»"
    and "𝒯o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. F.FUN (ψ (b, a) x) e)"
    proof -
      show "𝒯o e b = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. F.FUN (ψ (b, a) x) e)"
        using 𝒯o_def by auto
      moreover have "(λx. F.FUN (ψ (b, a) x) e)  Hom.set (b, a)  F.SET b"
      proof
        fix x
        assume x: "x  Hom.set (b, a)"
        hence "«ψ (b, a) x : b  a»" using assms ide_a Hom.ψ_mapsto by auto
        hence "F.FUN (ψ (b, a) x)  F.SET a  F.SET b"
          using S.Fun_mapsto [of "F (ψ (b, a) x)"] by fastforce
        thus "F.FUN (ψ (b, a) x) e  F.SET b" using e by auto
      qed
      ultimately show "«𝒯o e b : Y a b S F b»"
        using ide_a b S.mkArr_in_hom [of "Hom.set (b, a)" "F.SET b"] Hom.set_subset_Univ
              S.mkIde_set
        by auto
    qed

    text‹
      For each @{term "e  F.SET a"}, the mapping @{term "𝒯o e"} gives the components
      of a natural transformation @{term 𝒯} from @{term "Y a"} to @{term F}.
›

    lemma 𝒯o_e_induces_transformation:
    assumes e: "e  S.set (F a)"
    shows "transformation_by_components Cop.comp S (Y a) F (𝒯o e)"
    proof
      fix b :: 'c
      assume b: "Cop.ide b"
      show "«𝒯o e b : Y a b S F b»"
        using ide_a b e 𝒯o_e_ide by simp
      next
      fix g :: 'c
      assume g: "Cop.arr g"
      let ?b = "Cop.dom g"
      let ?b' = "Cop.cod g"
      show "𝒯o e (Cop.cod g) S Y a g = F g S 𝒯o e (Cop.dom g)"
      proof -
        have 1: "𝒯o e (Cop.cod g) S Y a g
                   = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                             ((λx. F.FUN (ψ (?b', a) x) e)
                                o (φ (?b', a) o Cop.comp g o ψ (?b, a)))"
        proof -
          have "S.arr (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                      (λs. F.FUN (ψ (Cop.cod g, a) s) e)) 
                S.dom (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                      (λs. F.FUN (ψ (Cop.cod g, a) s) e)) = Y a (Cop.cod g) 
                S.cod (S.mkArr (Hom.set (Cop.cod g, a)) (F.SET (Cop.cod g))
                      (λs. F.FUN (ψ (Cop.cod g, a) s) e)) = F (Cop.cod g)"
            using Cop.cod_char 𝒯o_e_ide [of e ?b'] 𝒯o_e_ide [of e ?b'] e g
            by (metis Cop.ide_char Cop.ide_cod S.in_homE)
          moreover have "Y a g = S.mkArr (Hom.set (Cop.dom g, a)) (Hom.set (Cop.cod g, a))
                                         (φ (Cop.cod g, a)  Cop.comp g  ψ (Cop.dom g, a))"
            using Y_ide_arr [of a g ?b' ?b] ide_a g by auto
          ultimately show ?thesis
            using ide_a e g Y_ide_arr Cop.cod_char 𝒯o_e_ide
                  S.comp_mkArr [of "Hom.set (?b, a)" "Hom.set (?b', a)"
                                   "φ (?b', a) o Cop.comp g o ψ (?b, a)"
                                   "F.SET ?b'" "λx. F.FUN (ψ (?b', a) x) e"]
            by (metis C.ide_dom Cop.arr_char preserves_arr)
        qed
        also have "... = S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                                 (F.FUN g o (λx. F.FUN (ψ (?b, a) x) e))"
        proof (intro S.mkArr_eqI')
          have "(λx. F.FUN (ψ (?b', a) x) e)
                   o (φ (?b', a) o Cop.comp g o ψ (?b, a))  Hom.set (?b, a)  F.SET ?b'"
          proof -
            have "S.arr (S (𝒯o e ?b') (Y a g))"
              using ide_a e g 𝒯o_e_ide [of e ?b'] Y_ide_arr(1) [of a "C.dom g" "C.cod g" g]
                    Cop.ide_char Cop.ide_cod
              by blast
            thus ?thesis using 1 S.arr_mkArr by simp
          qed
          thus "S.arr (S.mkArr (Hom.set (?b, a)) (F.SET ?b')
                               ((λx. F.FUN (ψ (?b', a) x) e)
                                  o (φ (?b', a) o Cop.comp g o ψ (?b, a))))"
            using ide_a e g Hom.set_subset_Univ S.arr_mkArr by force
          show "x. x  Hom.set (?b, a) 
                        ((λx. F.FUN (ψ (?b', a) x) e) o (φ (?b', a) o Cop.comp g o ψ (?b, a))) x
                        = (F.FUN g o (λx. F.FUN (ψ (?b, a) x) e)) x"
          proof -
            fix x
            assume x: "x  Hom.set (?b, a)"
            have "((λx. (F.FUN o ψ (?b', a)) x e)
                       o (φ (?b', a) o Cop.comp g o ψ (?b, a))) x
                    = F.FUN (ψ (?b', a) (φ (?b', a) (C (ψ (?b, a) x) g))) e"
              by simp
            also have "... = (F.FUN g o (F.FUN o ψ (?b, a)) x) e"
            proof -
              have 1: "«ψ (Cop.dom g, a) x : Cop.dom g  a»"
                using ide_a x g Hom.ψ_mapsto [of ?b a] by auto
              moreover have "S.seq (F g) (F (ψ (C.cod g, a) x))"
                using 1 g by (intro S.seqI', auto)
              moreover have (C.dom g, a) (φ (C.dom g, a) (C (ψ (C.cod g, a) x) g)) =
                             C (ψ (C.cod g, a) x) g"
                using g 1 Hom.ψ_φ [of "C (ψ (?b, a) x) g" ?b' a] by fastforce
              ultimately show ?thesis
                using assms F.preserves_comp by fastforce
            qed
            also have "... = (F.FUN g o (λx. F.FUN (ψ (?b, a) x) e)) x" by fastforce
            finally show "((λx. F.FUN (ψ (?b', a) x) e)
                             o (φ (?b', a) o Cop.comp g o ψ (?b, a))) x
                            = (F.FUN g o (λx. F.FUN (ψ (?b, a) x) e)) x"
              by simp
          qed
        qed
        also have "... = F g S 𝒯o e (Cop.dom g)"
        proof -
          have "S.arr (F g)  F g = S.mkArr (F.SET ?b) (F.SET ?b') (F.FUN g)"
            using g S.mkArr_Fun [of "F g"] by simp
          moreover have
              "S.arr (𝒯o e ?b) 
               𝒯o e ?b = S.mkArr (Hom.set (?b, a)) (F.SET ?b) (λx. F.FUN (ψ (?b, a) x) e)"
            using e g 𝒯o_e_ide
            by (metis C.ide_cod Cop.arr_char Cop.dom_char S.in_homE)
          ultimately show ?thesis
            using S.comp_mkArr [of "Hom.set (?b, a)" "F.SET ?b" "λx. F.FUN (ψ (?b, a) x) e"
                                   "F.SET ?b'" "F.FUN g"]
            by metis
        qed
        finally show ?thesis by blast
      qed
    qed

    abbreviation 𝒯 :: "'s  'c  's"
    where "𝒯 e  transformation_by_components.map Cop.comp S (Y a) (𝒯o e)"

  end

  locale yoneda_lemma_fixed_e =
    yoneda_lemma C S φ F a
  for C :: "'c comp" (infixr "" 55)
  and S :: "'s comp" (infixr "S" 55)
  and φ :: "'c * 'c  'c  's"
  and F :: "'c  's"
  and a :: 'c
  and e :: 's +
  assumes E: "e  F.SET a"
  begin

    interpretation 𝒯e: transformation_by_components Cop.comp S ‹Y a F ‹𝒯o e
      using E 𝒯o_e_induces_transformation by auto

    lemma natural_transformation_𝒯e:
    shows "natural_transformation Cop.comp S (Y a) F (𝒯 e)" ..

    lemma 𝒯e_ide:
    assumes "Cop.ide b"
    shows "S.arr (𝒯 e b)"
    and "𝒯 e b = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. F.FUN (ψ (b, a) x) e)"
      using assms apply fastforce
      using assms 𝒯o_def by auto

  end

  locale yoneda_lemma_fixed_τ =
    yoneda_lemma C S φ F a +
    τ: set_valued_transformation Cop.comp S "Y a" F τ
  for C :: "'c comp" (infixr "" 55)
  and S :: "'s comp" (infixr "S" 55)
  and φ :: "'c * 'c  'c  's"
  and F :: "'c  's"
  and a :: 'c
  and τ :: "'c  's"
  begin

    text‹
      The key lemma: The component @{term "τ b"} of @{term τ} at an arbitrary object @{term b}
      is completely determined by the single element @{term "τ.FUN a (φ (a, a) a)  F.SET a"}.
›

    lemma τ_ide:
    assumes b: "Cop.ide b"
    shows "τ b = S.mkArr (Hom.set (b, a)) (F.SET b)
                         (λx. (F.FUN (ψ (b, a) x) (τ.FUN a (φ (a, a) a))))"
    proof -
      let ?φa = "φ (a, a) a"
      have φa: "φ (a, a) a  Hom.set (a, a)" using ide_a Hom.φ_mapsto [of a a] by fastforce
      have 1: "τ b = S.mkArr (Hom.set (b, a)) (F.SET b) (τ.FUN b)"
        using ide_a b S.mkArr_Fun [of "τ b"] Hom.set_map by auto
      also have
          "... = S.mkArr (Hom.set (b, a)) (F.SET b) (λx. (F.FUN (ψ (b, a) x) (τ.FUN a ?φa)))"
      proof (intro S.mkArr_eqI')
        show "S.arr (S.mkArr (Hom.set (b, a)) (F.SET b) (τ.FUN b))"
          using ide_a b 1 S.mkArr_Fun [of "τ b"] Hom.set_map by auto
        show "x. x  Hom.set (b, a)  τ.FUN b x = (F.FUN (ψ (b, a) x) (τ.FUN a ?φa))"
        proof -
          fix x
          assume x: "x  Hom.set (b, a)"
          let ?ψx = (b, a) x"
          have ψx: "«?ψx : b  a»"
            using ide_a b x Hom.ψ_mapsto [of b a] by auto
          show "τ.FUN b x = (F.FUN (ψ (b, a) x) (τ.FUN a ?φa))"
          proof -
            have "τ.FUN b x = S.Fun (τ b S Y a ?ψx) ?φa"
            proof -
              have "τ.FUN b x = τ.FUN b ((φ (b, a) o Cop.comp ?ψx) a)"
                using ide_a b x ψx Hom.φ_ψ
               by (metis C.comp_cod_arr C.in_homE C.ide_dom Cop.comp_def comp_apply)
              also have "τ.FUN b ((φ (b, a) o Cop.comp ?ψx) a)
                           = (τ.FUN b o (φ (b, a) o Cop.comp ?ψx o ψ (a, a))) ?φa"
                using ide_a b C.ide_in_hom by simp
              also have "... = S.Fun (τ b S Y a ?ψx) ?φa"
              proof -
                have "S.arr (Y a ?ψx)"
                  using ide_a ψx preserves_arr by (elim C.in_homE, auto)
                moreover have "Y a ?ψx = S.mkArr (Hom.set (a, a)) (SET b)
                                                 (φ (b, a)  Cop.comp ?ψx  ψ (a, a))"
                  using ide_a b ψx preserves_hom Y_ide_arr Hom.set_map C.arrI by auto
                moreover have "S.arr (τ b)  τ b = S.mkArr (SET b) (F.SET b) (τ.FUN b)"
                  using ide_a b S.mkArr_Fun [of "τ b"] by simp
                ultimately have
                     "S.seq (τ b) (Y a ?ψx) 
                      τ b S Y a ?ψx =
                         S.mkArr (Hom.set (a, a)) (F.SET b)
                                 (τ.FUN b o (φ (b, a)  Cop.comp ?ψx  ψ (a, a)))"
                  using 1 S.comp_mkArr S.seqI
                  by (metis S.cod_mkArr S.dom_mkArr)
                thus ?thesis
                  using ide_a b x Hom.φ_mapsto S.Fun_mkArr by force
              qed
              finally show ?thesis by auto
            qed
            also have "... = S.Fun (F ?ψx S τ a) ?φa"
              using ide_a b ψx τ.naturality [of ?ψx] by force
            also have "... = F.FUN ?ψx (τ.FUN a ?φa)"
            proof -
              have "restrict (S.Fun (F ?ψx S τ a)) (Hom.set (a, a))
                               = restrict (F.FUN (ψ (b, a) x) o τ.FUN a) (Hom.set (a, a))"
              proof -
                have
                  "S.arr (F ?ψx S τ a) 
                   F ?ψx S τ a = S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?ψx o τ.FUN a)"
                proof
                  show 1: "S.seq (F ?ψx) (τ a)"
                    using ψx ide_a τ.preserves_cod F.preserves_dom by (elim C.in_homE, auto)
                  have "τ a = S.mkArr (Hom.set (a, a)) (F.SET a) (τ.FUN a)"
                    using ide_a 1 S.mkArr_Fun [of "τ a"] Hom.set_map by auto
                  moreover have "F ?ψx = S.mkArr (F.SET a) (F.SET b) (F.FUN ?ψx)"
                    using x ψx 1 S.mkArr_Fun [of "F ?ψx"] by fastforce
                  ultimately show "F ?ψx S τ a =
                                   S.mkArr (Hom.set (a, a)) (F.SET b) (F.FUN ?ψx o τ.FUN a)"
                    using 1 S.comp_mkArr [of "Hom.set (a, a)" "F.SET a" "τ.FUN a"
                                             "F.SET b" "F.FUN ?ψx"]
                    by (elim S.seqE, auto)
                qed
                thus ?thesis by force
              qed
              thus "S.Fun (F (ψ (b, a) x) S τ a) ?φa = F.FUN ?ψx (τ.FUN a ?φa)"
                 using ide_a φa restr_eqE [of "S.Fun (F ?ψx S τ a)"
                                           "Hom.set (a, a)" "F.FUN ?ψx o τ.FUN a"]
                 by simp
            qed
            finally show ?thesis by simp
          qed
        qed
      qed
      finally show ?thesis by auto
    qed

    text‹
      Consequently, if @{term τ'} is any natural transformation from @{term "Y a"} to @{term F}
      that agrees with @{term τ} at @{term a}, then @{term "τ' = τ"}.
›

    lemma eqI:
    assumes "natural_transformation Cop.comp S (Y a) F τ'" and "τ' a = τ a"
    shows "τ' = τ"
    proof (intro NaturalTransformation.eqI)
      interpret τ': natural_transformation Cop.comp S ‹Y a F τ' using assms by auto
      interpret T': yoneda_lemma_fixed_τ C S φ F a τ' ..
      show "natural_transformation Cop.comp S (Y a) F τ" ..
      show "natural_transformation Cop.comp S (Y a) F τ'" ..
      show "b. Cop.ide b  τ' b = τ b"
        using assms(2) τ_ide T'.τ_ide by simp
    qed

  end

  context yoneda_lemma
  begin

    text‹
      One half of the Yoneda lemma:
      The mapping @{term 𝒯} is an injection, with left inverse @{term },
      from the set @{term "F.SET a"} to the set of natural transformations from
      @{term "Y a"} to @{term F}.
›

    lemma 𝒯_is_injection:
    assumes "e  F.SET a"
    shows "natural_transformation Cop.comp S (Y a) F (𝒯 e)" and "ℰ (𝒯 e) = e"
    proof -
      interpret yoneda_lemma_fixed_e C S φ F a e
        using assms by (unfold_locales, auto)
      interpret 𝒯e: natural_transformation Cop.comp S ‹Y a F ‹𝒯 e
        using natural_transformation_𝒯e by auto
      show "natural_transformation Cop.comp S (Y a) F (𝒯 e)" ..
      show "ℰ (𝒯 e) = e"
        unfolding ℰ_def
        using assms 𝒯e_ide S.Fun_mkArr Hom.φ_mapsto Hom.ψ_φ ide_a
              F.preserves_ide S.Fun_ide restrict_apply C.ide_in_hom
        by (auto simp add: Pi_iff)
    qed

    lemma ℰτ_in_Fa:
    assumes "natural_transformation Cop.comp S (Y a) F τ"
    shows "ℰ τ  F.SET a"
    proof -
      interpret τ: natural_transformation Cop.comp S ‹Y a F τ using assms by auto
      interpret yoneda_lemma_fixed_τ C S φ F a τ ..
      show ?thesis
      proof (unfold ℰ_def)
        have "S.arr (τ a)  S.Dom (τ a) = Hom.set (a, a)  S.Cod (τ a) = F.SET a"
          using ide_a Hom.set_map by auto
        hence "τ.FUN a  Hom.set (a, a)  F.SET a"
          using S.Fun_mapsto by blast
        thus "τ.FUN a (φ (a, a) a)  F.SET a"
          using ide_a Hom.φ_mapsto by fastforce
      qed
    qed

    text‹
      The other half of the Yoneda lemma:
      The mapping @{term 𝒯} is a surjection, with right inverse @{term },
      taking natural transformations from @{term "Y a"} to @{term F}
      to elements of @{term "F.SET a"}.
›

    lemma 𝒯_is_surjection:
    assumes "natural_transformation Cop.comp S (Y a) F τ"
    shows "ℰ τ  F.SET a" and "𝒯 (τ) = τ"
    proof -
      interpret natural_transformation Cop.comp S ‹Y a F τ using assms by auto
      interpret yoneda_lemma_fixed_τ C S φ F a τ ..
      show 1: "ℰ τ  F.SET a" using assms ℰτ_in_Fa by auto
      interpret yoneda_lemma_fixed_e C S φ F a ‹ℰ τ
        using 1 by (unfold_locales, auto)
      interpret 𝒯e: natural_transformation Cop.comp S ‹Y a F ‹𝒯 (τ)
        using natural_transformation_𝒯e by auto
      show "𝒯 (τ) = τ"
      proof (intro eqI)
        show "natural_transformation Cop.comp S (Y a) F (𝒯 (τ))" ..
        show "𝒯 (τ) a = τ a"
          using ide_a τ_ide [of a] 𝒯e_ide ℰ_def by simp
      qed
    qed
     
    text‹
      The main result.
›

    theorem yoneda_lemma:
    shows "bij_betw 𝒯 (F.SET a) {τ. natural_transformation Cop.comp S (Y a) F τ}"
      using 𝒯_is_injection 𝒯_is_surjection by (intro bij_betwI, auto)

  end

  text‹
    We now consider the special case in which @{term F} is the contravariant
    functor @{term "Y a'"}.  Then for any @{term e} in Hom.set (a, a')›
    we have @{term "𝒯 e = Y (ψ (a, a') e)"}, and @{term 𝒯} is a bijection from
    Hom.set (a, a')› to the set of natural transformations from @{term "Y a"}
    to @{term "Y a'"}.  It then follows that that the Yoneda functor @{term Y}
    is a fully faithful functor from @{term C} to the functor category [Cop, S]›.
›

  locale yoneda_lemma_for_hom =
    C: category C +
    Cop: dual_category C +
    S: replete_set_category S +
    yoneda_functor_fixed_object C S φ a +
    Ya': yoneda_functor_fixed_object C S φ a' +
    yoneda_lemma C S φ "Y a'" a
  for C :: "'c comp" (infixr "" 55)
  and S :: "'s comp" (infixr "S" 55)
  and φ :: "'c * 'c  'c  's"
  and F :: "'c  's"
  and a :: 'c
  and a' :: 'c +
  assumes ide_a': "C.ide a'"
  begin

    text‹
      In case @{term F} is the functor @{term "Y a'"}, for any @{term "e  Hom.set (a, a')"}
      the induced natural transformation @{term "𝒯 e"} from @{term "Y a"} to @{term "Y a'"}
      is just @{term "Y (ψ (a, a') e)"}.
›

    lemma 𝒯_equals_Yoψ:
    assumes e: "e  Hom.set (a, a')"
    shows "𝒯 e = Y (ψ (a, a') e)"
    proof -
      let ?ψe = (a, a') e"
      have ψe: "«?ψe : a  a'»" using ide_a ide_a' e Hom.ψ_mapsto [of a a'] by auto
      interpret Ye: natural_transformation Cop.comp S ‹Y a ‹Y a' ‹Y ?ψe
        using Y_arr_is_transformation [of ?ψe] ψe by (elim C.in_homE, auto)
      interpret yoneda_lemma_fixed_e C S φ ‹Y a' a e
        using ide_a ide_a' e S.set_mkIde Hom.set_map
        by (unfold_locales, simp_all)
      interpret 𝒯e: natural_transformation Cop.comp S ‹Y a ‹Y a' ‹𝒯 e
        using natural_transformation_𝒯e by auto
      interpret yoneda_lemma_fixed_τ C S φ ‹Y a' a ‹𝒯 e ..
      have "natural_transformation Cop.comp S (Y a) (Y a') (Y ?ψe)" ..
      moreover have "natural_transformation Cop.comp S (Y a) (Y a') (𝒯 e)" ..
      moreover have "𝒯 e a = Y ?ψe a"
      proof -
        have 1: "S.arr (𝒯 e a)"
          using ide_a e 𝒯e.preserves_reflects_arr by simp
        have 2: "𝒯 e a = S.mkArr (Hom.set (a, a)) (Ya'.SET a) (λx. Ya'.FUN (ψ (a, a) x) e)"
          using ide_a 𝒯o_def 𝒯e_ide by simp
        also have
            "... = S.mkArr (Hom.set (a, a)) (Hom.set (a, a')) (φ (a, a') o C ?ψe o ψ (a, a))"
        proof (intro S.mkArr_eqI)
          show "S.arr (S.mkArr (Hom.set (a, a)) (Ya'.SET a) (λx. Ya'.FUN (ψ (a, a) x) e))"
            using ide_a e 1 2 by simp
          show "Hom.set (a, a) = Hom.set (a, a)" ..
          show 3: "Ya'.SET a = Hom.set (a, a')"
            using ide_a ide_a' Y_simp Hom.set_map by simp
          show "x. x  Hom.set (a, a) 
                      Ya'.FUN (ψ (a, a) x) e = (φ (a, a') o C ?ψe o ψ (a, a)) x"
          proof -
            fix x
            assume x: "x  Hom.set (a, a)"
            have ψx: "«ψ (a, a) x : a  a»" using ide_a x Hom.ψ_mapsto [of a a] by auto
            have "S.arr (Y a' (ψ (a, a) x)) 
                  Y a' (ψ (a, a) x) = S.mkArr (Hom.set (a, a')) (Hom.set (a, a'))
                                              (φ (a, a')  Cop.comp (ψ (a, a) x)  ψ (a, a'))"
              using Y_ide_arr ide_a ide_a' ψx by blast
            hence "Ya'.FUN (ψ (a, a) x) e = (φ (a, a')  Cop.comp (ψ (a, a) x)  ψ (a, a')) e"
              using e 3 S.Fun_mkArr Ya'.preserves_reflects_arr [of (a, a) x"] by simp
            also have "... = (φ (a, a') o C ?ψe o ψ (a, a)) x" by simp
            finally show "Ya'.FUN (ψ (a, a) x) e = (φ (a, a') o C ?ψe o ψ (a, a)) x" by auto
          qed
        qed
        also have "... = Y ?ψe a"
          using ide_a ide_a' Y_arr_ide ψe by simp
        finally show "𝒯 e a = Y ?ψe a" by auto
      qed
      ultimately show ?thesis using eqI by auto
    qed

    lemma Y_injective_on_homs:
    assumes "«f : a  a'»" and "«f' : a  a'»" and "map f = map f'"
    shows "f = f'"
    proof -
      have "f = ψ (a, a') (φ (a, a') f)"
        using assms ide_a Hom.ψ_φ by simp
      also have "... = ψ (a, a') ((𝒯 (φ (a, a') f)))"
        using ide_a ide_a' assms(1) 𝒯_is_injection Hom.φ_mapsto Hom.set_map
        by (elim C.in_homE, simp add: Pi_iff)
      also have "... = ψ (a, a') ((Y (ψ (a, a') (φ (a, a') f))))"
        using assms Hom.φ_mapsto [of a a'] 𝒯_equals_Yoψ [of "φ (a, a') f"] by force
      also have "... = ψ (a, a') ((𝒯 (φ (a, a') f')))"
        using assms Hom.φ_mapsto [of a a'] ide_a Hom.ψ_φ Y_def
              𝒯_equals_Yoψ [of "φ (a, a') f'"]
        by fastforce
      also have "... = ψ (a, a') (φ (a, a') f')"
        using ide_a ide_a' assms(2) 𝒯_is_injection Hom.φ_mapsto Hom.set_map
        by (elim C.in_homE, simp add: Pi_iff)
      also have "... = f'"
        using assms ide_a Hom.ψ_φ by simp
      finally show "f = f'" by auto
    qed

    lemma Y_surjective_on_homs:
    assumes τ: "natural_transformation Cop.comp S (Y a) (Y a') τ"
    shows "Y (ψ (a, a') (τ)) = τ"
      using ide_a ide_a' τ 𝒯_is_surjection 𝒯_equals_Yoψ ℰτ_in_Fa Hom.set_map by simp

  end

  context yoneda_functor
  begin

    lemma is_faithful_functor:
    shows "faithful_functor C Cop_S.comp map"
    proof
      fix f :: 'c and f' :: 'c
      assume par: "C.par f f'" and ff': "map f = map f'"
      show "f = f'"
      proof -
        interpret Ya': yoneda_functor_fixed_object C S φ ‹C.cod f
          using par by (unfold_locales, auto)
        interpret yoneda_lemma_for_hom C S φ ‹Y (C.cod f) ‹C.dom f ‹C.cod f
          using par by (unfold_locales, auto)
        show "f = f'" using par ff' Y_injective_on_homs [of f f'] by fastforce
      qed
    qed

    lemma is_full_functor:
    shows "full_functor C Cop_S.comp map"
    proof
      fix a :: 'c and a' :: 'c and t
      assume a: "C.ide a" and a': "C.ide a'"
      assume t: "«t : map a [Cop,S] map a'»"
      show "e. «e : a  a'»  map e = t"
      proof
        interpret Ya': yoneda_functor_fixed_object C S φ a'
          using a' by (unfold_locales, auto)
        interpret yoneda_lemma_for_hom C S φ ‹Y a' a a'
          using a a' by (unfold_locales, auto)
        have NT: "natural_transformation Cop.comp S (Y a) (Y a') (Cop_S.Map t)"
          using t a' Y_def Cop_S.Map_dom Cop_S.Map_cod Cop_S.dom_char Cop_S.cod_char
                Cop_S.in_homE Cop_S.arrE
          by metis
        hence 1: "ℰ (Cop_S.Map t)  Hom.set (a, a')"
          using ℰτ_in_Fa ide_a ide_a' Hom.set_map by simp
        moreover have "map (ψ (a, a') ((Cop_S.Map t))) = t"
        proof (intro Cop_S.arr_eqI)
          have 2: "«map (ψ (a, a') ((Cop_S.Map t))) : map a [Cop,S] map a'»"
            using 1 ide_a ide_a' Hom.ψ_mapsto [of a a'] by blast
          show "Cop_S.arr t" using t by blast
          show "Cop_S.arr (map (ψ (a, a') ((Cop_S.Map t))))" using 2 by blast
          show 3: "Cop_S.Map (map (ψ (a, a') ((Cop_S.Map t)))) = Cop_S.Map t"
            using NT Y_surjective_on_homs Y_def by simp
          show 4: "Cop_S.Dom (map (ψ (a, a') ((Cop_S.Map t)))) = Cop_S.Dom t"
            using t 2 natural_transformation_axioms Cop_S.Map_dom by (metis Cop_S.in_homE)
          show "Cop_S.Cod (map (ψ (a, a') ((Cop_S.Map t)))) = Cop_S.Cod t"
            using 2 3 4 t Cop_S.Map_cod by (metis Cop_S.in_homE)
        qed
        ultimately show "«ψ (a, a') ((Cop_S.Map t)) : a  a'» 
                         map (ψ (a, a') ((Cop_S.Map t))) = t"
          using ide_a ide_a' Hom.ψ_mapsto by auto
      qed
    qed

  end

  sublocale yoneda_functor  faithful_functor C Cop_S.comp map
    using is_faithful_functor by auto
  sublocale yoneda_functor  full_functor C Cop_S.comp map using is_full_functor by auto
  sublocale yoneda_functor  fully_faithful_functor C Cop_S.comp map ..

end

Theory Adjunction

(*  Title:       Adjunction
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter Adjunction

theory Adjunction
imports Yoneda
begin

  text‹
    This theory defines the notions of adjoint functor and adjunction in various
    ways and establishes their equivalence.
    The notions ``left adjoint functor'' and ``right adjoint functor'' are defined
    in terms of universal arrows.
    ``Meta-adjunctions'' are defined in terms of natural bijections between hom-sets,
    where the notion of naturality is axiomatized directly.
    ``Hom-adjunctions'' formalize the notion of adjunction in terms of natural
    isomorphisms of hom-functors.
    ``Unit-counit adjunctions'' define adjunctions in terms of functors equipped
    with unit and counit natural transformations that satisfy the usual
    ``triangle identities.''
    The adjunction› locale is defined as the grand unification of all the
    definitions, and includes formulas that connect the data from each of them.
    It is shown that each of the definitions induces an interpretation of the
    adjunction› locale, so that all the definitions are essentially equivalent.
    Finally, it is shown that right adjoint functors are unique up to natural
    isomorphism.

    The reference \cite{Wikipedia-Adjoint-Functors} was useful in constructing this theory.
›

  section "Left Adjoint Functor"

  text‹
    ``@{term e} is an arrow from @{term "F x"} to @{term y}.''
›

  locale arrow_from_functor =
    C: category C +
    D: category D +
    F: "functor" D C F
    for D :: "'d comp"     (infixr "D" 55)
    and C :: "'c comp"     (infixr "C" 55)
    and F :: "'d  'c"
    and x :: 'd
    and y :: 'c
    and e :: 'c +
    assumes arrow: "D.ide x  C.in_hom e (F x) y"
  begin

    notation C.in_hom      ("«_ : _ C _»")
    notation D.in_hom      ("«_ : _ D _»")

    text‹
      ``@{term g} is a @{term[source=true] D}-coextension of @{term f} along @{term e}.''
›

    definition is_coext :: "'d  'c  'd  bool"
    where "is_coext x' f g  «g : x' D x»  f = e C F g"

  end

  text‹
    ``@{term e} is a terminal arrow from @{term "F x"} to @{term y}.''
›

  locale terminal_arrow_from_functor =
    arrow_from_functor D C F x y e
    for D :: "'d comp"     (infixr "D" 55)
    and C :: "'c comp"     (infixr "C" 55)
    and F :: "'d  'c"
    and x :: 'd
    and y :: 'c
    and e :: 'c +
    assumes is_terminal: "arrow_from_functor D C F x' y f  (∃!g. is_coext x' f g)"
  begin

    definition the_coext :: "'d  'c  'd"
    where "the_coext x' f = (THE g. is_coext x' f g)"

    lemma the_coext_prop:
    assumes "arrow_from_functor D C F x' y f"
    shows "«the_coext x' f : x' D x»" and "f = e C F (the_coext x' f)"
      using assms is_terminal the_coext_def is_coext_def theI2 [of "λg. is_coext x' f g"]
       apply metis
      using assms is_terminal the_coext_def is_coext_def theI2 [of "λg. is_coext x' f g"]
      by metis

    lemma the_coext_unique:
    assumes "arrow_from_functor D C F x' y f" and "is_coext x' f g"
    shows "g = the_coext x' f"
      using assms is_terminal the_coext_def the_equality by metis

  end

  text‹
    A left adjoint functor is a functor F: D → C›
    that enjoys the following universal coextension property: for each object
    @{term y} of @{term C} there exists an object @{term x} of @{term D} and an
    arrow e ∈ C.hom (F x) y› such that for any arrow
    f ∈ C.hom (F x') y› there exists a unique g ∈ D.hom x' x›
    such that @{term "f = C e (F g)"}.
›

  locale left_adjoint_functor =
    C: category C +
    D: category D +
    "functor" D C F
    for D :: "'d comp"     (infixr "D" 55)
    and C :: "'c comp"     (infixr "C" 55)
    and F :: "'d  'c" +
    assumes ex_terminal_arrow: "C.ide y  (x e. terminal_arrow_from_functor D C F x y e)"
  begin

    notation C.in_hom      ("«_ : _ C _»")
    notation D.in_hom      ("«_ : _ D _»")

  end

  section "Right Adjoint Functor"

  text‹
    ``@{term e} is an arrow from @{term x} to @{term "G y"}.''
›

  locale arrow_to_functor =
    C: category C +
    D: category D +
    G: "functor" C D G
    for C :: "'c comp"     (infixr "C" 55)
    and D :: "'d comp"     (infixr "D" 55)
    and G :: "'c  'd"
    and x :: 'd
    and y :: 'c
    and e :: 'd +
    assumes arrow: "C.ide y  D.in_hom e x (G y)"
  begin

    notation C.in_hom      ("«_ : _ C _»")
    notation D.in_hom      ("«_ : _ D _»")

    text‹
      ``@{term f} is a @{term[source=true] C}-extension of @{term g} along @{term e}.''
›

    definition is_ext :: "'c  'd  'c  bool"
    where "is_ext y' g f  «f : y C y'»  g = G f D e"

  end

  text‹
    ``@{term e} is an initial arrow from @{term x} to @{term "G y"}.''
›

  locale initial_arrow_to_functor =
    arrow_to_functor C D G x y e
    for C :: "'c comp"     (infixr "C" 55)
    and D :: "'d comp"     (infixr "D" 55)
    and G :: "'c  'd"
    and x :: 'd
    and y :: 'c
    and e :: 'd +
    assumes is_initial: "arrow_to_functor C D G x y' g  (∃!f. is_ext y' g f)"
  begin

    definition the_ext :: "'c  'd  'c"
    where "the_ext y' g = (THE f. is_ext y' g f)"

    lemma the_ext_prop:
    assumes "arrow_to_functor C D G x y' g"
    shows "«the_ext y' g : y C y'»" and "g = G (the_ext y' g) D e"
      using assms is_initial the_ext_def is_ext_def theI2 [of "λf. is_ext y' g f"]
       apply metis
      using assms is_initial the_ext_def is_ext_def theI2 [of "λf. is_ext y' g f"]
      by metis

    lemma the_ext_unique:
    assumes "arrow_to_functor C D G x y' g" and "is_ext y' g f"
    shows "f = the_ext y' g"
      using assms is_initial the_ext_def the_equality by metis

  end

  text‹
    A right adjoint functor is a functor G: C → D›
    that enjoys the following universal extension property:
    for each object @{term x} of @{term D} there exists an object @{term y} of @{term C}
    and an arrow e ∈ D.hom x (G y)› such that for any arrow
    g ∈ D.hom x (G y')› there exists a unique f ∈ C.hom y y'›
    such that @{term "h = D e (G f)"}.
›

  locale right_adjoint_functor =
    C: category C +
    D: category D +
    "functor" C D G
    for C :: "'c comp"     (infixr "C" 55)
    and D :: "'d comp"     (infixr "D" 55)
    and G :: "'c  'd" +
    assumes initial_arrows_exist: "D.ide x  (y e. initial_arrow_to_functor C D G x y e)"
  begin

    notation C.in_hom      ("«_ : _ C _»")
    notation D.in_hom      ("«_ : _ D _»")

  end

  section "Various Definitions of Adjunction"

  subsection "Meta-Adjunction"

  text‹
    A ``meta-adjunction'' consists of a functor F: D → C›,
    a functor G: C → D›, and for each object @{term x}
    of @{term C} and @{term y} of @{term D} a bijection between
    C.hom (F y) x› to D.hom y (G x)› which is natural in @{term x}
    and @{term y}.  The naturality is easy to express at the meta-level without having
    to resort to the formal baggage of ``set category,'' ``hom-functor,''
    and ``natural isomorphism,'' hence the name.
›

  locale meta_adjunction =
    C: category C +
    D: category D +
    F: "functor" D C F +
    G: "functor" C D G
    for C :: "'c comp"     (infixr "C" 55)
    and D :: "'d comp"     (infixr "D" 55)
    and F :: "'d  'c"
    and G :: "'c  'd"
    and φ :: "'d  'c  'd"
    and ψ :: "'c  'd  'c" +
    assumes φ_in_hom: " D.ide y; C.in_hom f (F y) x   D.in_hom (φ y f) y (G x)"
    and ψ_in_hom: " C.ide x; D.in_hom g y (G x)   C.in_hom (ψ x g) (F y) x"
    and ψ_φ: " D.ide y; C.in_hom f (F y) x   ψ x (φ y f) = f"
    and φ_ψ: " C.ide x; D.in_hom g y (G x)   φ y (ψ x g) = g"
    and φ_naturality: " C.in_hom f x x'; D.in_hom g y' y; C.in_hom h (F y) x  
                         φ y' (f C h C F g) = G f D φ y h D g"
  begin

    notation C.in_hom ("«_ : _ C _»")
    notation D.in_hom ("«_ : _ D _»")

    text‹
      The naturality of @{term ψ} is a consequence of the naturality of @{term φ}
      and the other assumptions.
›

    lemma ψ_naturality:
    assumes f: "«f : x C x'»" and g: "«g : y' D y»" and h: "«h : y D G x»"
    shows "f C ψ x h C F g = ψ x' (G f D h D g)"
    proof -
      have "«f C ψ x h C F g : F y' C x'»"
        using f g h ψ_in_hom [of x h] by fastforce
      moreover have "«(G f D h) D g : y' D G x'»"
        using f g h φ_in_hom by auto
      moreover have "ψ x' (φ y' (f C ψ x h C F g)) = ψ x' (G f D φ y (ψ x h) D g)"
      proof -
        have "«ψ x h : F y C x»"
          using f h ψ_in_hom by auto
        thus ?thesis using f g φ_naturality
          by force
      qed
      ultimately show ?thesis
        using f h ψ_φ φ_ψ
        by (metis C.arrI C.ide_dom C.in_homE D.arrI D.ide_dom D.in_homE)
    qed

    lemma respects_natural_isomorphism:
    assumes "natural_isomorphism D C F' F τ" and "natural_isomorphism C D G G' μ"
    shows "meta_adjunction C D F' G'
             (λy f. μ (C.cod f) D φ y (f C inverse_transformation.map D C F τ y))
             (λx g. ψ x ((inverse_transformation.map C D G' μ x) D g) C τ (D.dom g))"
    proof -
      interpret τ: natural_isomorphism D C F' F τ
        using assms(1) by simp
      interpret τ': inverse_transformation D C F' F τ
        ..
      interpret μ: natural_isomorphism C D G G' μ
        using assms(2) by simp
      interpret μ': inverse_transformation C D G G' μ
        ..
      let ?φ' = "λy f. μ (C.cod f) D φ y (f C τ'.map y)"
      let ?ψ' = "λx g. ψ x (μ'.map x D g) C τ (D.dom g)"
      show "meta_adjunction C D F' G' ?φ' ?ψ'"
      proof
        show "y f x. D.ide y; «f : F' y C x»
                          «μ (C.cod f) D φ y (f C τ'.map y) : y D G' x»"
        proof -
          fix x y f
          assume y: "D.ide y" and f: "«f : F' y C x»"
          show "«μ (C.cod f) D φ y (f C τ'.map y) : y D G' x»"
          proof (intro D.comp_in_homI)
            show "«μ (C.cod f) : G x D G' x»"
              using f by fastforce
            show "«φ y (f C τ'.map y) : y D G x»"
              using f y φ_in_hom by auto
          qed
        qed
        show "x g y. C.ide x; «g : y D G' x»
                          «ψ x (μ'.map x D g) C τ (D.dom g) : F' y C x»"
        proof -
          fix x y g
          assume x: "C.ide x" and g: "«g : y D G' x»"
          show "«ψ x (μ'.map x D g) C τ (D.dom g) : F' y C x»"
          proof (intro C.comp_in_homI)
            show "«τ (D.dom g) : F' y C F y»"
              using g by fastforce
            show "«ψ x (μ'.map x D g) : F y C x»"
              using x g ψ_in_hom by auto
          qed
        qed
        show "y f x. D.ide y; «f : F' y C x»
                           ψ x (μ'.map x D μ (C.cod f) D φ y (f C τ'.map y)) C
                                τ (D.dom (μ (C.cod f) D φ y (f C τ'.map y))) =
                              f"
        proof -
          fix x y f
          assume y: "D.ide y" and f: "«f : F' y C x»"
          have 1: "«φ y (f C τ'.map y) : y D G x»"
            using f y φ_in_hom by auto
          show "ψ x (μ'.map x D μ (C.cod f) D φ y (f C τ'.map y)) C
                  τ (D.dom (μ (C.cod f) D φ y (f C τ'.map y))) =
                f"
          proof -
            have "ψ x (μ'.map x D μ (C.cod f) D φ y (f C τ'.map y)) C
                    τ (D.dom (μ (C.cod f) D φ y (f C τ'.map y))) =
                  ψ x ((μ'.map x D μ (C.cod f)) D φ y (f C τ'.map y)) C
                    τ (D.dom (μ (C.cod f) D φ y (f C τ'.map y)))"
              using D.comp_assoc by simp
            also have "... = ψ x (φ y (f C τ'.map y)) C τ y"
            proof -
              have "C.cod f = x"
                using f by auto
              moreover have "μ'.map x D μ x = G x"
                using f μ'.inverts_components [of x] by force
              moreover have "D.dom (μ x D φ y (f C τ'.map y)) = y"
                using f y 1 by fastforce
              ultimately show ?thesis
                using f y 1 D.comp_cod_arr by auto
            qed
            also have "... = f"
              using f y ψ_φ C.comp_assoc τ'.inverts_components [of y] C.comp_arr_dom
              by fastforce
            finally show ?thesis by blast
          qed
        qed
        show "x g y. C.ide x; «g : y D G' x»
                          μ (C.cod (ψ x (μ'.map x D g) C τ (D.dom g))) D
                               φ y ((ψ x (μ'.map x D g) C τ (D.dom g)) C τ'.map y) =
                             g"
        proof -
          fix x y g
          assume x: "C.ide x" and g: "«g : y D G' x»"
          have 1: "«ψ x (μ'.map x D g) : F y C x»"
            using x g ψ_in_hom by auto
          show "μ (C.cod (ψ x (μ'.map x D g) C τ (D.dom g))) D
                  φ y ((ψ x (μ'.map x D g) C τ (D.dom g)) C τ'.map y) =
                g"
          proof -
            have "μ (C.cod (ψ x (μ'.map x D g) C τ (D.dom g))) D
                    φ y ((ψ x (μ'.map x D g) C τ (D.dom g)) C τ'.map y) =
                  μ (C.cod (ψ x (μ'.map x D g) C τ (D.dom g))) D
                    φ y (ψ x (μ'.map x D g) C τ (D.dom g) C τ'.map y)"
              using C.comp_assoc by simp
            also have "... = μ x D φ y (ψ x (μ'.map x D g))"
            proof -
              have "D.dom g = y"
                using g by auto
              moreover have "τ y C τ'.map y = F y"
                using g τ'.inverts_components [of y] by fastforce
              moreover have "C.cod (ψ x (μ'.map x D g) C τ (D.dom g)) = x"
                using g 1 by fastforce
              ultimately show ?thesis
                using x g 1 C.comp_arr_dom by auto
            qed
            also have "... = μ x D μ'.map x D g"
              using x g φ_ψ by auto
            also have "... = (μ x D μ'.map x) D g"
              using D.comp_assoc by simp
            also have "... = g"
              using x g μ'.inverts_components [of x] D.comp_cod_arr by fastforce
            finally show ?thesis by blast
          qed
        qed
        show "f x x' g y' y h. «f : x C x'»; «g : y' D y»; «h : F' y C x»
                   μ (C.cod (f C h C F' g)) D φ y' ((f C h C F' g) C τ'.map y') =
                      G' f D (μ (C.cod h) D φ y (h C τ'.map y)) D g"
        proof -
          fix x y x' y' f g h
          assume f: "«f : x C x'»" and g: "«g : y' D y»" and h: "«h : F' y C x»"
          show "μ (C.cod (f C h C F' g)) D φ y' ((f C h C F' g) C τ'.map y') =
                G' f D (μ (C.cod h) D φ y (h C τ'.map y)) D g"
          proof -
            have "μ (C.cod (f C h C F' g)) D φ y' ((f C h C F' g) C τ'.map y') =
                  μ x' D φ y' ((f C h C F' g) C τ'.map y')"
              using f g h by fastforce
            also have "... = μ x' D φ y' (f C (h C τ'.map y) C F g)"
              using g τ'.naturality C.comp_assoc by auto
            also have "... = (μ x' D G f) D φ y (h C τ'.map y) D g"
              using f g h φ_naturality [of f x x' g y' y "h C τ'.map y"] D.comp_assoc
              by fastforce
            also have "... = (G' f D μ x) D φ y (h C τ'.map y) D g"
              using f μ.naturality by auto
            also have "... = G' f D (μ (C.cod h) D φ y (h C τ'.map y)) D g"
              using h D.comp_assoc by auto
            finally show ?thesis by blast
          qed
        qed
      qed
    qed

  end

  subsection "Hom-Adjunction"

  text‹
    The bijection between hom-sets that defines an adjunction can be represented
    formally as a natural isomorphism of hom-functors.  However, stating the definition
    this way is more complex than was the case for meta_adjunction›.
    One reason is that we need to have a ``set category'' that is suitable as
    a target category for the hom-functors, and since the arrows of the categories
    @{term C} and @{term D} will in general have distinct types, we need a set category
    that simultaneously embeds both.  Another reason is that we simply have to formally
    construct the various categories and functors required to express the definition.

    This is a good place to point out that I have often included more sublocales
    in a locale than are strictly required.  The main reason for this is the fact that
    the locale system in Isabelle only gives one name to each entity introduced by
    a locale: the name that it has in the first locale in which it occurs.
    This means that entities that make their first appearance deeply nested in sublocales
    will have to be referred to by long qualified names that can be difficult to
    understand, or even to discover.  To counteract this, I have typically introduced
    sublocales before the superlocales that contain them to ensure that the entities
    in the sublocales can be referred to by short meaningful (and predictable) names.
    In my opinion, though, it would be better if the locale system would make entities
    that occur in multiple locales accessible by \emph{all} possible qualified names,
    so that the most perspicuous name could be used in any particular context.
›

  locale hom_adjunction =
    C: category C +
    D: category D +
    S: replete_set_category S +
    Cop: dual_category C +
    Dop: dual_category D +
    CopxC: product_category Cop.comp C +
    DopxD: product_category Dop.comp D +
    DopxC: product_category Dop.comp C +
    F: "functor" D C F +
    G: "functor" C D G +
    HomC: hom_functor C S φC +
    HomD: hom_functor D S φD +
    Fop: dual_functor Dop.comp Cop.comp F +
    FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
    DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
    Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
    Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
    Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
    Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
    Φ: set_valued_transformation DopxC.comp S Hom_FopxC.map Hom_DopxG.map Φ +
    Ψ: set_valued_transformation DopxC.comp S Hom_DopxG.map Hom_FopxC.map Ψ +
    ΦΨ: inverse_transformations DopxC.comp S Hom_FopxC.map Hom_DopxG.map Φ Ψ
    for C :: "'c comp"     (infixr "C" 55)
    and D :: "'d comp"     (infixr "D" 55)
    and S :: "'s comp"     (infixr "S" 55)
    and φC :: "'c * 'c  'c  's"
    and φD :: "'d * 'd  'd  's"
    and F :: "'d  'c"
    and G :: "'c  'd"
    and Φ :: "'d * 'c  's"
    and Ψ :: "'d * 'c  's"
  begin

    notation C.in_hom      ("«_ : _ C _»")
    notation D.in_hom      ("«_ : _ D _»")

    abbreviation ψC :: "'c * 'c  's  'c"
    where "ψC  HomC.ψ"

    abbreviation ψD :: "'d * 'd  's  'd"
    where "ψD  HomD.ψ"

  end

  subsection "Unit/Counit Adjunction"

  text‹
    Expressed in unit/counit terms, an adjunction consists of functors
    F: D → C› and G: C → D›, equipped with natural transformations
    η: 1 → GF› and ε: FG → 1› satisfying certain ``triangle identities''.
›

  locale unit_counit_adjunction =
    C: category C +
    D: category D +
    F: "functor" D C F +
    G: "functor" C D G +
    GF: composite_functor D C D F G +
    FG: composite_functor C D C G F +
    FGF: composite_functor D C C F F o G +
    GFG: composite_functor C D D G G o F +
    η: natural_transformation D D D.map G o F η +
    ε: natural_transformation C C F o G C.map ε +: natural_transformation D C F F o G o F F o η +
    ηG: natural_transformation C D G G o F o G η o G +
    εF: natural_transformation D C F o G o F F ε o F +: natural_transformation C D G o F o G G G o ε +
    εFoFη: vertical_composite D C F F o G o F F F o η ε o F +
    GεoηG: vertical_composite C D G G o F o G G η o G G o ε
    for C :: "'c comp"     (infixr "C" 55)
    and D :: "'d comp"     (infixr "D" 55)
    and F :: "'d  'c"
    and G :: "'c  'd"
    and η :: "'d  'd"
    and ε :: "'c  'c" +
    assumes triangle_F: "εFoFη.map = F"
    and triangle_G: "GεoηG.map = G"
  begin

    notation C.in_hom      ("«_ : _ C _»")
    notation D.in_hom      ("«_ : _ D _»")

  end

  lemma unit_determines_counit:
  assumes "unit_counit_adjunction C D F G η ε"
  and "unit_counit_adjunction C D F G η ε'"
  shows "ε = ε'"
  proof -
    (* IDEA:  ε' = ε'FG o (FGε o FηG) = ε'ε o FηG = εFG o (ε'FG o FηG) = ε *)
    interpret Adj: unit_counit_adjunction C D F G η ε using assms(1) by auto
    interpret Adj': unit_counit_adjunction C D F G η ε' using assms(2) by auto
    interpret FGFG: composite_functor C D C G F o G o F ..
    interpret FGε: natural_transformation C C (F o G) o (F o G) F o G (F o G) o ε
      using Adj.ε.natural_transformation_axioms Adj.FG.natural_transformation_axioms
            horizontal_composite Adj.FG.functor_axioms
      by fastforce
    interpret FηG: natural_transformation C C F o G F o G o F o G F o η o G
      using Adj.η.natural_transformation_axioms Adj.Fη.natural_transformation_axioms
            Adj.G.natural_transformation_axioms horizontal_composite
      by blast
    interpret ε'ε: natural_transformation C C F o G o F o G Adj.C.map ε' o ε
    proof -
      have "natural_transformation C C ((F o G) o (F o G)) Adj.C.map (ε' o ε)"
        using Adj.ε.natural_transformation_axioms Adj'.ε.natural_transformation_axioms
              horizontal_composite Adj.C.is_functor comp_functor_identity
        by (metis (no_types, lifting))
      thus "natural_transformation C C (F o G o F o G) Adj.C.map (ε' o ε)"
        using o_assoc by metis
    qed
    interpret ε'εoFηG: vertical_composite
                         C C F o G F o G o F o G Adj.C.map F o η o G ε' o ε ..
    have "ε' = vertical_composite.map C C (F o Adj.GεoηG.map) ε'"
      using vcomp_ide_dom [of C C "F o G" Adj.C.map ε'] Adj.triangle_G
      by (simp add: Adj'.ε.natural_transformation_axioms)
    also have "... = vertical_composite.map C C
                       (vertical_composite.map C C (F o η o G) (F o G o ε)) ε'"
      using whisker_left Adj.F.functor_axioms Adj.Gε.natural_transformation_axioms
            Adj.ηG.natural_transformation_axioms o_assoc
      by (metis (no_types, lifting))
    also have "... = vertical_composite.map C C
                       (vertical_composite.map C C (F o η o G) (ε' o F o G)) ε"
    proof -
      have "vertical_composite.map C C
              (vertical_composite.map C C (F o η o G) (F o G o ε)) ε'
              = vertical_composite.map C C (F o η o G)
                  (vertical_composite.map C C (F o G o ε) ε')"
        using vcomp_assoc
        by (metis (no_types, lifting) Adj'.ε.natural_transformation_axioms
            FGε.natural_transformation_axioms FηG.natural_transformation_axioms o_assoc)
      also have "... = vertical_composite.map C C (F o η o G)
                         (vertical_composite.map C C (ε' o F o G) ε)"
      proof -
        have "ε'  Adj.C.map = ε'"
          using Adj'.ε.natural_transformation_axioms hcomp_ide_dom by simp
        moreover have "Adj.C.map  ε = ε"
          using Adj.ε.natural_transformation_axioms hcomp_ide_cod by simp
        moreover have "ε'  (F o G) = ε' o F  G" by auto
        ultimately show ?thesis
          using Adj'.ε.natural_transformation_axioms Adj.ε.natural_transformation_axioms
                interchange_spc [of C C "F o G" Adj.C.map ε C "F o G" Adj.C.map ε']
          by simp
      qed
      also have "... = vertical_composite.map C C
                         (vertical_composite.map C C (F o η o G) (ε' o F o G)) ε"
        using vcomp_assoc
        by (metis Adj'.εF.natural_transformation_axioms Adj.G.natural_transformation_axioms
            Adj.ε.natural_transformation_axioms FηG.natural_transformation_axioms
            horizontal_composite)
      finally show ?thesis by simp
    qed
    also have "... = vertical_composite.map C C
                       (vertical_composite.map D C (F o η) (ε' o F) o G) ε"
      using whisker_right Adj'.εF.natural_transformation_axioms
            Adj.Fη.natural_transformation_axioms Adj.G.functor_axioms
      by metis
    also have "... = vertical_composite.map C C (F o G) ε"
      using Adj'.triangle_F by simp
    also have "... = ε"
      using vcomp_ide_cod Adj.ε.natural_transformation_axioms by simp
    finally show ?thesis by simp
  qed

  lemma counit_determines_unit:
  assumes "unit_counit_adjunction C D F G η ε"
  and "unit_counit_adjunction C D F G η' ε"
  shows "η = η'"
  proof -
    interpret Adj: unit_counit_adjunction C D F G η ε using assms(1) by auto
    interpret Adj': unit_counit_adjunction C D F G η' ε using assms(2) by auto
    interpret GFGF: composite_functor D C D F G o F o G ..
    interpret GFη: natural_transformation D D G o F (G o F) o (G o F) (G o F) o η
      using Adj.η.natural_transformation_axioms Adj.GF.functor_axioms
            Adj.GF.natural_transformation_axioms comp_functor_identity horizontal_composite
      by (metis (no_types, lifting))
    interpret η'GF: natural_transformation D D G o F (G o F) o (G o F) η' o (G o F)
      using Adj'.η.natural_transformation_axioms Adj.GF.functor_axioms
            Adj.GF.natural_transformation_axioms comp_identity_functor horizontal_composite
      by (metis (no_types, lifting))
    interpret GεF: natural_transformation D D G o F o G o F G o F G o ε o F
      using Adj.ε.natural_transformation_axioms Adj.F.natural_transformation_axioms
            Adj.Gε.natural_transformation_axioms horizontal_composite
      by blast
    interpret η'η: natural_transformation D D Adj.D.map G o F o G o F η' o η
    proof -
      have "natural_transformation D D Adj.D.map ((G o F) o (G o F)) (η' o η)"
        using Adj.η.natural_transformation_axioms Adj'.η.natural_transformation_axioms
              horizontal_composite Adj.D.natural_transformation_axioms hcomp_ide_cod
        by (metis (no_types, lifting))
      thus "natural_transformation D D Adj.D.map (G o F o G o F) (η' o η)"
        using o_assoc by metis
    qed
    interpret GεFoη'η: vertical_composite
                         D D Adj.D.map G o F o G o F G o F η' o η G o ε o F ..
    have "η' = vertical_composite.map D D η' (G o Adj.εFoFη.map)"
      using vcomp_ide_cod [of D D  Adj.D.map "G o F" η'] Adj.triangle_F
      by (simp add: Adj'.η.natural_transformation_axioms)
    also have "... = vertical_composite.map D D η'
                       (vertical_composite.map D D (G o (F o η)) (G o (ε o F)))"
      using whisker_left Adj.Fη.natural_transformation_axioms Adj.G.functor_axioms
            Adj.εF.natural_transformation_axioms
      by fastforce
    also have "... = vertical_composite.map D D
                       (vertical_composite.map D D η' (G o (F o η))) (G o ε o F)"
      using vcomp_assoc Adj'.η.natural_transformation_axioms
            GFη.natural_transformation_axioms GεF.natural_transformation_axioms o_assoc
      by (metis (no_types, lifting))
    also have "... = vertical_composite.map D D
                       (vertical_composite.map D D η (η' o G o F)) (G o ε o F)"
    proof -
      have "η'  Adj.D.map = η'"
        using Adj'.η.natural_transformation_axioms hcomp_ide_dom by simp
      moreover have "η' o (G o F) = η' o G o F  G o (F o η) = G o F o η" by auto
      ultimately show ?thesis
        using interchange_spc [of D D Adj.D.map "G o F" η D Adj.D.map "G o F" η']
              Adj.η.natural_transformation_axioms Adj'.η.natural_transformation_axioms
        by simp
    qed
    also have "... = vertical_composite.map D D η
                       (vertical_composite.map D D (η' o G o F) (G o ε o F))"
      using vcomp_assoc
      by (metis (no_types, lifting) Adj.η.natural_transformation_axioms
          GεF.natural_transformation_axioms η'GF.natural_transformation_axioms o_assoc)
    also have "... = vertical_composite.map D D η
                       (vertical_composite.map C D (η' o G) (G o ε) o F)"
      using whisker_right Adj'.ηG.natural_transformation_axioms Adj.F.functor_axioms
            Adj.Gε.natural_transformation_axioms
      by fastforce
    also have "... = vertical_composite.map D D η (G o F)"
      using Adj'.triangle_G by simp
    also have "... = η"
      using vcomp_ide_dom Adj.GF.functor_axioms Adj.η.natural_transformation_axioms by simp
    finally show ?thesis by simp
  qed

  subsection "Adjunction"

  text‹
    The grand unification of everything to do with an adjunction.
›

  locale adjunction =
    C: category C +
    D: category D +
    S: replete_set_category S +
    Cop: dual_category C +
    Dop: dual_category D +
    CopxC: product_category Cop.comp C +
    DopxD: product_category Dop.comp D +
    DopxC: product_category Dop.comp C +
    idDop: identity_functor Dop.comp +
    HomC: hom_functor C S φC +
    HomD: hom_functor D S φD +
    F: left_adjoint_functor D C F +
    G: right_adjoint_functor C D G +
    GF: composite_functor D C D F G +
    FG: composite_functor C D C G F +
    FGF: composite_functor D C C F FG.map +
    GFG: composite_functor C D D G GF.map +
    Fop: dual_functor Dop.comp Cop.comp F +
    FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map +
    DopxG: product_functor Dop.comp C Dop.comp D Dop.map G +
    Hom_FopxC: composite_functor DopxC.comp CopxC.comp S FopxC.map HomC.map +
    Hom_DopxG: composite_functor DopxC.comp DopxD.comp S DopxG.map HomD.map +
    Hom_FopxC: set_valued_functor DopxC.comp S Hom_FopxC.map +
    Hom_DopxG: set_valued_functor DopxC.comp S Hom_DopxG.map +
    η: natural_transformation D D D.map GF.map η +
    ε: natural_transformation C C FG.map C.map ε +: natural_transformation D C F F o G o F F o η +
    ηG: natural_transformation C D G G o F o G η o G +
    εF: natural_transformation D C F o G o F F ε o F +: natural_transformation C D G o F o G G G o ε +
    εFoFη: vertical_composite D C F FGF.map F F o η ε o F +
    GεoηG: vertical_composite C D G GFG.map G η o G G o ε +
    φψ: meta_adjunction C D F G φ ψ +
    ηε: unit_counit_adjunction C D F G η ε +
    ΦΨ: hom_adjunction C D S φC φD F G Φ Ψ
    for C :: "'c comp"     (infixr "C" 55)
    and D :: "'d comp"     (infixr "D" 55)
    and S :: "'s comp"     (infixr "S" 55)
    and φC :: "'c * 'c  'c  's"
    and φD :: "'d * 'd  'd  's"
    and F :: "'d  'c"
    and G :: "'c  'd"
    and φ :: "'d  'c  'd"
    and ψ :: "'c  'd  'c"
    and η :: "'d  'd"
    and ε :: "'c  'c"
    and Φ :: "'d * 'c  's"
    and Ψ :: "'d * 'c  's" +
    assumes φ_in_terms_of_η: " D.ide y; «f : F y C x»   φ y f = G f D η y"
    and ψ_in_terms_of_ε: " C.ide x; «g : y D G x»   ψ x g = ε x C F g"
    and η_in_terms_of_φ: "D.ide y  η y = φ y (F y)"
    and ε_in_terms_of_ψ: "C.ide x  ε x = ψ x (G x)"
    and φ_in_terms_of_Φ: " D.ide y; «f : F y C x»  
                              φ y f = (ΦΨ.ψD (y, G x) o S.Fun (Φ (y, x)) o φC (F y, x)) f"
    and ψ_in_terms_of_Ψ: " C.ide x; «g : y D G x»  
                              ψ x g = (ΦΨ.ψC (F y, x) o S.Fun (Ψ (y, x)) o φD (y, G x)) g"
    and Φ_in_terms_of_φ:
           " C.ide x; D.ide y  
                Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                    (φD (y, G x) o φ y o ΦΨ.ψC (F y, x))"
    and Ψ_in_terms_of_ψ:
           " C.ide x; D.ide y  
                Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                    (φC (F y, x) o ψ x o ΦΨ.ψD (y, G x))"

  section "Meta-Adjunctions Induce Unit/Counit Adjunctions"

  context meta_adjunction
  begin

    interpretation GF: composite_functor D C D F G ..
    interpretation FG: composite_functor C D C G F ..
    interpretation FGF: composite_functor D C C F FG.map ..
    interpretation GFG: composite_functor C D D G GF.map ..

    definition ηo :: "'d  'd"
    where "ηo y = φ y (F y)"

    lemma ηo_in_hom:
    assumes "D.ide y"
    shows "«ηo y : y D G (F y)»"
      using assms D.ide_in_hom ηo_def φ_in_hom by force

    lemma φ_in_terms_of_ηo:
    assumes "D.ide y" and "«f : F y C x»"
    shows "φ y f = G f D ηo y"
    proof (unfold ηo_def)
      have 1: "«F y : F y C F y»"
        using assms(1) D.ide_in_hom by blast
      hence "φ y (F y) = φ y (F y) D y"
        by (metis assms(1) D.in_homE φ_in_hom D.comp_arr_dom)
      thus "φ y f = G f D φ y (F y)"
        using assms 1 D.ide_in_hom by (metis C.comp_arr_dom C.in_homE φ_naturality)
    qed

    lemma φ_F_char:
    assumes "«g : y' D y»"
    shows "φ y' (F g) = ηo y D g"
      using assms ηo_def φ_in_hom [of y "F y" "F y"]
            D.comp_cod_arr [of "D (φ y (F y)) g" "G (F y)"]
            φ_naturality [of "F y" "F y" "F y" g y' y "F y"]
      by (metis D.arr_cod D.cod_cod D.comp_in_homI' D.ide_char' D.ide_in_hom D.in_homE
          F.is_natural_2 F.preserves_hom)

    interpretation η: transformation_by_components D D D.map GF.map ηo
    proof
      show "a. D.ide a  «ηo a : D.map a D GF.map a»"
        using ηo_def φ_in_hom D.ide_in_hom by force
      fix f
      assume f: "D.arr f"
      show "ηo (D.cod f) D D.map f = GF.map f D ηo (D.dom f)"
        using f φ_F_char [of "D.map f" "D.dom f" "D.cod f"]
              φ_in_terms_of_ηo [of "D.dom f" "F f" "F (D.cod f)"]
        by force
    qed

    lemma η_map_simp:
    assumes "D.ide y"
    shows "η.map y = φ y (F y)"
      using assms η.map_simp_ide ηo_def by simp

    definition εo :: "'c  'c"
    where "εo x = ψ x (G x)"

    lemma εo_in_hom:
    assumes "C.ide x"
    shows "«εo x : F (G x) C x»"
      using assms C.ide_in_hom εo_def ψ_in_hom by force

    lemma ψ_in_terms_of_εo:
    assumes "C.ide x" and "«g : y D G x»"
    shows "ψ x g = εo x C F g"
    proof -
      have "εo x C F g = x C ψ x (G x) C F g"
        using assms εo_def ψ_in_hom [of x "G x" "G x"]
              C.comp_cod_arr [of "ψ x (G x) C F g" x]
        by fastforce
      also have "... = ψ x (G x D G x D g)"
        using assms ψ_naturality [of x x x g y "G x" "G x"] by force
      also have "... = ψ x g"
        using assms D.comp_cod_arr by fastforce
      finally show ?thesis by simp
    qed

    lemma ψ_G_char:
    assumes "«f: x C x'»"
    shows "ψ x' (G f) = f C εo x"
    proof (unfold εo_def)
      have 0: "C.ide x  C.ide x'" using assms by auto
      thus "ψ x' (G f) = f C ψ x (G x)"
        using 0 assms ψ_naturality ψ_in_hom [of x "G x" "G x"] G.preserves_hom εo_def
              ψ_in_terms_of_εo G.is_natural_1 C.ide_in_hom
        by (metis C.arrI C.in_homE)
    qed

    interpretation ε: transformation_by_components C C FG.map C.map εo
      apply unfold_locales
      using εo_in_hom
       apply simp
      using ψ_G_char ψ_in_terms_of_εo
      by (metis C.arr_iff_in_hom C.ide_cod C.map_simp G.preserves_hom comp_apply)

    lemma ε_map_simp:
    assumes "C.ide x"
    shows "ε.map x = ψ x (G x)"
      using assms εo_def by simp

    interpretation FD: composite_functor D D C D.map F ..
    interpretation CF: composite_functor D C C F C.map ..
    interpretation GC: composite_functor C C D C.map G ..
    interpretation DG: composite_functor C D D G D.map ..

    interpretation: natural_transformation D C F F o G o F F o η.map›
    proof -
      have "natural_transformation D C F (F o (G o F)) (F o η.map)"
        using η.natural_transformation_axioms F.natural_transformation_axioms
              horizontal_composite
        by fastforce
      thus "natural_transformation D C F (F o G o F) (F o η.map)"
        using o_assoc by metis
    qed

    interpretation εF: natural_transformation D C F o G o F F ‹ε.map o F
      using ε.natural_transformation_axioms F.natural_transformation_axioms
            horizontal_composite
      by fastforce

    interpretation ηG: natural_transformation C D G G o F o G ‹η.map o G
      using η.natural_transformation_axioms G.natural_transformation_axioms
            horizontal_composite
      by fastforce

    interpretation: natural_transformation C D G o F o G G G o ε.map›
    proof - 
      have "natural_transformation C D (G o (F o G)) G (G o ε.map)"
        using ε.natural_transformation_axioms G.natural_transformation_axioms
            horizontal_composite
        by fastforce
      thus "natural_transformation C D (G o F o G) G (G o ε.map)"
        using o_assoc by metis
    qed

    interpretation εFoFη: vertical_composite D C F F o G o F F F o η.map› ‹ε.map o F
      ..
    interpretation GεoηG: vertical_composite C D G G o F o G G ‹η.map o G G o ε.map›
      ..

    lemma unit_counit_F:
    assumes "D.ide y"
    shows "F y = εo (F y) C F (ηo y)"
      using assms ψ_in_terms_of_εo ηo_def ψ_φ ηo_in_hom F.preserves_ide C.ide_in_hom by metis

    lemma unit_counit_G:
    assumes "C.ide x"
    shows "G x = G (εo x) D ηo (G x)"
      using assms φ_in_terms_of_ηo εo_def φ_ψ εo_in_hom G.preserves_ide D.ide_in_hom by metis

    lemma induces_unit_counit_adjunction':
    shows "unit_counit_adjunction C D F G η.map ε.map"
    proof
      show "εFoFη.map = F"
        using εFoFη.is_natural_transformation εFoFη.map_simp_ide unit_counit_F
              F.natural_transformation_axioms
        by (intro NaturalTransformation.eqI, auto)
      show "GεoηG.map = G"
        using GεoηG.is_natural_transformation GεoηG.map_simp_ide unit_counit_G
              G.natural_transformation_axioms
        by (intro NaturalTransformation.eqI, auto)
    qed

    definition η :: "'d  'd" where "η  η.map"
    definition ε :: "'c  'c" where "ε  ε.map"

    theorem induces_unit_counit_adjunction:
    shows "unit_counit_adjunction C D F G η ε"
      unfolding η_def ε_def
      using induces_unit_counit_adjunction' by simp

    lemma η_is_natural_transformation:
    shows "natural_transformation D D D.map GF.map η"
      unfolding η_def ..

    lemma ε_is_natural_transformation:
    shows "natural_transformation C C FG.map C.map ε"
      unfolding ε_def ..

    text‹
      From the defined @{term η} and @{term ε} we can recover the original @{term φ} and @{term ψ}.
›

    lemma φ_in_terms_of_η:
    assumes "D.ide y" and "«f : F y C x»"
    shows "φ y f = G f D η y"
      using assms η_def by (simp add: φ_in_terms_of_ηo)

    lemma ψ_in_terms_of_ε:
    assumes "C.ide x" and "«g : y D G x»"
    shows "ψ x g = ε x C F g"
      using assms ε_def by (simp add: ψ_in_terms_of_εo)

  end

  section "Meta-Adjunctions Induce Left and Right Adjoint Functors"

  context meta_adjunction
  begin

    interpretation unit_counit_adjunction C D F G η ε
      using induces_unit_counit_adjunction η_def ε_def by auto

    lemma has_terminal_arrows_from_functor:
    assumes x: "C.ide x"
    shows "terminal_arrow_from_functor D C F (G x) x (ε x)"
    and "y' f. arrow_from_functor D C F y' x f
                    terminal_arrow_from_functor.the_coext D C F (G x) (ε x) y' f = φ y' f"
    proof -
      interpret εx: arrow_from_functor D C F G x x ‹ε x
        apply unfold_locales
        using x ε.preserves_hom G.preserves_ide by auto
      have 1: "y' f. arrow_from_functor D C F y' x f 
                      εx.is_coext y' f (φ y' f)  (g'. εx.is_coext y' f g'  g' = φ y' f)"
      proof
        fix y' :: 'd and f :: 'c
        assume f: "arrow_from_functor D C F y' x f"
        show "εx.is_coext y' f (φ y' f)"
          using f x ε_def φ_in_hom ψ_φ ψ_in_terms_of_ε εx.is_coext_def arrow_from_functor.arrow
          by metis
        show "g'. εx.is_coext y' f g'  g' = φ y' f"
          using εo_def ψ_in_terms_of_εo x ε_map_simp φ_ψ εx.is_coext_def ε_def by simp
      qed
      interpret εx: terminal_arrow_from_functor D C F G x x ‹ε x
        apply unfold_locales using 1 by blast
      show "terminal_arrow_from_functor D C F (G x) x (ε x)" ..
      show "y' f. arrow_from_functor D C F y' x f  εx.the_coext y' f = φ y' f"
        using 1 εx.the_coext_def by auto
    qed

    lemma has_left_adjoint_functor:
    shows "left_adjoint_functor D C F"
      apply unfold_locales using has_terminal_arrows_from_functor by auto

    lemma has_initial_arrows_to_functor:
    assumes y: "D.ide y"
    shows "initial_arrow_to_functor C D G y (F y) (η y)"
    and "x' g. arrow_to_functor C D G y x' g 
                  initial_arrow_to_functor.the_ext C D G (F y) (η y) x' g = ψ x' g"
    proof -
      interpret ηy: arrow_to_functor C D G y F y ‹η y
        apply unfold_locales using y by auto
      have 1: "x' g. arrow_to_functor C D G y x' g 
                         ηy.is_ext x' g (ψ x' g)  (f'. ηy.is_ext x' g f'  f' = ψ x' g)"
      proof
        fix x' :: 'c and g :: 'd
        assume g: "arrow_to_functor C D G y x' g"
        show "ηy.is_ext x' g (ψ x' g)"
          using g y ψ_in_hom φ_ψ φ_in_terms_of_η ηy.is_ext_def arrow_to_functor.arrow η_def
          by metis
        show "f'. ηy.is_ext x' g f'  f' = ψ x' g"
          using y ηo_def φ_in_terms_of_ηo η_map_simp ψ_φ ηy.is_ext_def η_def by simp
      qed
      interpret ηy: initial_arrow_to_functor C D G y F y ‹η y
        apply unfold_locales using 1 by blast
      show "initial_arrow_to_functor C D G y (F y) (η y)" ..
      show "x' g. arrow_to_functor C D G y x' g  ηy.the_ext x' g = ψ x' g"
        using 1 ηy.the_ext_def by auto
    qed

    lemma has_right_adjoint_functor:
    shows "right_adjoint_functor C D G"
      apply unfold_locales using has_initial_arrows_to_functor by auto

  end

  section "Unit/Counit Adjunctions Induce Meta-Adjunctions"

  context unit_counit_adjunction
  begin

    definition φ :: "'d  'c  'd"
    where "φ y h = G h D η y"

    definition ψ :: "'c  'd  'c"
    where "ψ x h = ε x C F h"

    interpretation meta_adjunction C D F G φ ψ
    proof
      fix x :: 'c and y :: 'd and f :: 'c
      assume y: "D.ide y" and f: "«f : F y C x»"
      show 0: "«φ y f : y D G x»"
        using f y G.preserves_hom η.preserves_hom φ_def D.ide_in_hom by auto
      show x (φ y f) = f"
      proof -
        have x (φ y f) = (ε x C F (G f)) C F (η y)"
          using y f φ_def ψ_def C.comp_assoc by auto
        also have "... = (f C ε (F y)) C F (η y)"
          using y f ε.naturality by auto
        also have "... = f"
          using y f εFoFη.map_simp_2 triangle_F C.comp_arr_dom D.ide_in_hom C.comp_assoc
          by fastforce
        finally show ?thesis by auto
      qed
      next
      fix x :: 'c and y :: 'd and g :: 'd
      assume x: "C.ide x" and g: "«g : y D G x»"
      show "«ψ x g : F y C x»" using g x ψ_def by fastforce
      show y (ψ x g) = g"
      proof -
        have y (ψ x g) = (G (ε x) D η (G x)) D g"
          using g x φ_def ψ_def η.naturality [of g] D.comp_assoc by auto
        also have "... = g"
          using x g triangle_G D.comp_ide_arr GεoηG.map_simp_ide by auto
        finally show ?thesis by auto
      qed
      next
      fix f :: 'c and g :: 'd and h :: 'c and x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
      assume f: "«f : x C x'»" and g: "«g : y' D y»" and h: "«h : F y C x»"
      show y' (f C h C F g) = G f D φ y h D g"
        using φ_def f g h η.naturality D.comp_assoc by fastforce
    qed

    theorem induces_meta_adjunction:
    shows "meta_adjunction C D F G φ ψ" ..

    text‹
      From the defined @{term φ} and @{term ψ} we can recover the original @{term η} and @{term ε}.
›

    lemma η_in_terms_of_φ:
    assumes "D.ide y"
    shows "η y = φ y (F y)"
      using assms φ_def D.comp_cod_arr by auto

    lemma ε_in_terms_of_ψ:
    assumes "C.ide x"
    shows "ε x = ψ x (G x)"
      using assms ψ_def C.comp_arr_dom by auto

  end

  section "Left and Right Adjoint Functors Induce Meta-Adjunctions"

  text‹
    A left adjoint functor induces a meta-adjunction, modulo the choice of a
    right adjoint and counit.
›

  context left_adjoint_functor
  begin

    definition Go :: "'c  'd"
    where "Go a = (SOME b. e. terminal_arrow_from_functor D C F b a e)"

    definition εo :: "'c  'c"
    where "εo a = (SOME e. terminal_arrow_from_functor D C F (Go a) a e)"

    lemma Go_εo_terminal:
    assumes "b e. terminal_arrow_from_functor D C F b a e"
    shows "terminal_arrow_from_functor D C F (Go a) a (εo a)"
      using assms Go_def εo_def
            someI_ex [of "λb. e. terminal_arrow_from_functor D C F b a e"]
            someI_ex [of "λe. terminal_arrow_from_functor D C F (Go a) a e"]
      by simp

    text‹
      The right adjoint @{term G} to @{term F} takes each arrow @{term f} of
      @{term[source=true] C} to the unique @{term[source=true] D}-coextension of
      @{term "C f (εo (C.dom f))"} along @{term "εo (C.cod f)"}.
›

    definition G :: "'c  'd"
    where "G f = (if C.arr f then
                     terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (εo (C.cod f))
                                  (Go (C.dom f)) (f C εo (C.dom f))
                  else D.null)"

    lemma G_ide:
    assumes "C.ide x"
    shows "G x = Go x"
    proof -
      interpret terminal_arrow_from_functor D C F ‹Go x x ‹εo x
        using assms ex_terminal_arrow Go_εo_terminal by blast
      have 1: "arrow_from_functor D C F (Go x) x (εo x)" ..
      have "is_coext (Go x) (εo x) (Go x)"
        using arrow is_coext_def C.in_homE C.comp_arr_dom by auto
      hence "Go x = the_coext (Go x) (εo x)" using 1 the_coext_unique by blast
      moreover have "εo x = C x (εo (C.dom x))"
        using assms arrow C.comp_ide_arr C.seqI' C.ide_in_hom C.in_homE by metis
      ultimately show ?thesis using assms G_def C.cod_dom C.ide_in_hom C.in_homE by metis
    qed

    lemma G_is_functor:
    shows "functor C D G"
    proof
      fix f :: 'c
      assume "¬C.arr f"
      thus "G f = D.null" using G_def by auto
      next
      fix f :: 'c
      assume f: "C.arr f"
      let ?x = "C.dom f"
      let ?x' = "C.cod f"
      interpret: terminal_arrow_from_functor D C F ‹Go ?x ?x ‹εo ?x
        using f ex_terminal_arrow Go_εo_terminal by simp
      interpret x'ε: terminal_arrow_from_functor D C F ‹Go ?x' ?x' ‹εo ?x'
        using f ex_terminal_arrow Go_εo_terminal by simp
      have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (εo ?x))"
        using f xε.arrow by (unfold_locales, auto)
      have "G f = x'ε.the_coext (Go ?x) (C f (εo ?x))" using f G_def by simp
      hence Gf: "«G f : Go ?x D Go ?x'»  f C εo ?x = εo ?x' C F (G f)"
        using 1 x'ε.the_coext_prop by simp
      show "D.arr (G f)" using Gf by auto
      show "D.dom (G f) = G ?x" using f Gf G_ide by auto
      show "D.cod (G f) = G ?x'" using f Gf G_ide by auto
      next
      fix f f' :: 'c
      assume ff': "C.arr (C f' f)"
      have f: "C.arr f" using ff' by auto
      let ?x = "C.dom f"
      let ?x' = "C.cod f"
      let ?x'' = "C.cod f'"
      interpret: terminal_arrow_from_functor D C F ‹Go ?x ?x ‹εo ?x
        using f ex_terminal_arrow Go_εo_terminal by simp
      interpret x'ε: terminal_arrow_from_functor D C F ‹Go ?x' ?x' ‹εo ?x'
        using f ex_terminal_arrow Go_εo_terminal by simp
      interpret x''ε: terminal_arrow_from_functor D C F ‹Go ?x'' ?x'' ‹εo ?x''
        using ff' ex_terminal_arrow Go_εo_terminal by auto
      have 1: "arrow_from_functor D C F (Go ?x) ?x' (f C εo ?x)"
         using f xε.arrow by (unfold_locales, auto)
      have 2: "arrow_from_functor D C F (Go ?x') ?x'' (f' C εo ?x')"
         using ff' x'ε.arrow by (unfold_locales, auto)
      have "G f = x'ε.the_coext (Go ?x) (C f (εo ?x))"
        using f G_def by simp
      hence Gf: "D.in_hom (G f) (Go ?x) (Go ?x')  f C εo ?x = εo ?x' C F (G f)"
        using 1 x'ε.the_coext_prop by simp
      have "G f' = x''ε.the_coext (Go ?x') (f' C εo ?x')"
        using ff' G_def by auto
      hence Gf': "«G f' : Go (C.cod f) D Go (C.cod f')»  f' C εo ?x' = εo ?x'' C F (G f')"
        using 2 x''ε.the_coext_prop by simp
      show "G (f' C f) = G f' D G f"
      proof -
        have "x''ε.is_coext (Go ?x) ((f' C f) C εo ?x) (G f' D G f)"
        proof -
          have "«G f' D G f : Go (C.dom f) D Go (C.cod f')»" using 1 2 Gf Gf' by auto
          moreover have "(f' C f) C εo ?x = εo ?x'' C F (G f' D G f)"
          proof -
            have "(f' C f) C εo ?x = f' C f C εo ?x"
              using C.comp_assoc by force
            also have "... = (f' C εo ?x') C F (G f)"
              using Gf C.comp_assoc by fastforce
            also have "... = εo ?x'' C F (G f' D G f)"
              using Gf Gf' C.comp_assoc by fastforce
            finally show ?thesis by auto
          qed
          ultimately show ?thesis using x''ε.is_coext_def by auto
        qed
        moreover have "arrow_from_functor D C F (Go ?x) ?x'' ((f' C f) C εo ?x)"
           using ff' xε.arrow by (unfold_locales, blast)
        ultimately show ?thesis
          using ff' G_def x''ε.the_coext_unique C.seqE C.cod_comp C.dom_comp by auto
      qed
    qed

    interpretation G: "functor" C D G using G_is_functor by auto

    lemma G_simp:
    assumes "C.arr f"
    shows "G f = terminal_arrow_from_functor.the_coext D C F (Go (C.cod f)) (εo (C.cod f))
                                                             (Go (C.dom f)) (f C εo (C.dom f))"
      using assms G_def by simp

    interpretation idC: identity_functor C ..
    interpretation GF: composite_functor C D C G F ..

    interpretation ε: transformation_by_components C C GF.map C.map εo
    proof
      fix x :: 'c
      assume x: "C.ide x"
      show "«εo x : GF.map x C C.map x»"
      proof -
        interpret terminal_arrow_from_functor D C F ‹Go x x ‹εo x
          using x Go_εo_terminal ex_terminal_arrow by simp
        show ?thesis using x G_ide arrow by auto
      qed
      next
      fix f :: 'c
      assume f: "C.arr f"
      show "εo (C.cod f) C GF.map f = C.map f C εo (C.dom f)"
      proof -
        let ?x = "C.dom f"
        let ?x' = "C.cod f"
        interpret: terminal_arrow_from_functor D C F ‹Go ?x ?x ‹εo ?x
          using f Go_εo_terminal ex_terminal_arrow by simp
        interpret x'ε: terminal_arrow_from_functor D C F ‹Go ?x' ?x' ‹εo ?x'
          using f Go_εo_terminal ex_terminal_arrow by simp
        have 1: "arrow_from_functor D C F (Go ?x) ?x' (C f (εo ?x))"
           using f xε.arrow by (unfold_locales, auto)
        have "G f = x'ε.the_coext (Go ?x) (f C εo ?x)"
          using f G_simp by blast
        hence "x'ε.is_coext (Go ?x) (f C εo ?x) (G f)"
          using 1 x'ε.the_coext_prop x'ε.is_coext_def by auto
        thus ?thesis
          using f x'ε.is_coext_def by simp
      qed
    qed

    definition ψ
    where "ψ x h = C (ε.map x) (F h)"

    lemma ψ_in_hom:
    assumes "C.ide x" and "«g : y D G x»"
    shows "«ψ x g : F y C x»"
      unfolding ψ_def using assms ε.maps_ide_in_hom by auto

    lemma ψ_natural:
    assumes f: "«f : x C x'»" and g: "«g : y' D y»" and h: "«h : y D G x»"
    shows "f C ψ x h C F g = ψ x' ((G f D h) D g)"
    proof -
      have "f C ψ x h C F g = f C (ε.map x C F h) C F g"
        unfolding ψ_def by auto
      also have "... = (f C ε.map x) C F h C F g"
        using C.comp_assoc by fastforce
      also have "... = (f C ε.map x) C F (h D g)"
        using g h by fastforce
      also have "... = (ε.map x' C F (G f)) C F (h D g)"
        using f ε.naturality by auto
      also have "... = ε.map x' C F ((G f D h) D g)"
        using f g h C.comp_assoc by fastforce
      also have "... = ψ x' ((G f D h) D g)"
        unfolding ψ_def by auto
      finally show ?thesis by auto
    qed

    lemma ψ_inverts_coext:
    assumes x: "C.ide x" and g: "«g : y D G x»"
    shows "arrow_from_functor.is_coext D C F (G x) (ε.map x) y (ψ x g) g"
    proof -
      interpret: arrow_from_functor D C F ‹G x x ‹ε.map x
        using x ε.maps_ide_in_hom by (unfold_locales, auto)
      show "xε.is_coext y (ψ x g) g"
        using x g ψ_def xε.is_coext_def G_ide by blast
    qed

    lemma ψ_invertible:
    assumes y: "D.ide y" and f: "«f : F y C x»"
    shows "∃!g. «g : y D G x»  ψ x g = f"
    proof
      have x: "C.ide x" using f by auto
      interpret: terminal_arrow_from_functor D C F ‹Go x x ‹εo x
        using x ex_terminal_arrow Go_εo_terminal by auto
      have 1: "arrow_from_functor D C F y x f"
        using y f by (unfold_locales, auto)
      let ?g = "xε.the_coext y f"
      have x ?g = f"
        using 1 x y ψ_def xε.the_coext_prop G_ide ψ_inverts_coext xε.is_coext_def by simp
      thus "«?g : y D G x»  ψ x ?g = f"
        using 1 x xε.the_coext_prop G_ide by simp
      show "g'. «g' : y D G x»  ψ x g' = f  g' = ?g"
        using 1 x y ψ_inverts_coext G_ide xε.the_coext_unique by force
    qed

    definition φ
    where "φ y f = (THE g. «g : y D G (C.cod f)»  ψ (C.cod f) g = f)"

    lemma φ_in_hom:
    assumes "D.ide y" and "«f : F y C x»"
    shows "«φ y f : y D G x»"
      using assms ψ_invertible φ_def theI' [of "λg. «g : y D G x»  ψ x g = f"]
      by auto

    lemma φ_ψ:
    assumes "C.ide x" and "«g : y D G x»"
    shows y (ψ x g) = g"
    proof -
      have "C.cod (ψ x g) = x"
        using assms ψ_in_hom by auto
      hence y (ψ x g) = (THE g'. «g' : y D G x»  ψ x g' = ψ x g)"
        using φ_def by auto
      moreover have "∃!g'. «g' : y D G x»  ψ x g' = ψ x g"
        using assms ψ_in_hom ψ_invertible D.ide_dom by blast
      moreover have "«g : y D G x»  ψ x g = ψ x g"
        using assms(2) by auto
      ultimately show y (ψ x g) = g" by auto
    qed

    lemma ψ_φ:
    assumes "D.ide y" and "«f : F y C x»"
    shows x (φ y f) = f"
      using assms ψ_invertible φ_def theI' [of "λg. «g : y D G x»  ψ x g = f"]
      by auto

    lemma φ_natural:
    assumes "«f : x C x'»" and "«g : y' D y»" and "«h : F y C x»"
    shows y' (f C h C F g) = (G f D φ y h) D g"
    proof -
      have "C.ide x'  D.ide y  D.in_hom (φ y h) y (G x)"
        using assms φ_in_hom by auto
      thus ?thesis
        using assms D.comp_in_homI G.preserves_hom ψ_natural [of f x x' g y' y y h"] φ_ψ ψ_φ
        by auto
    qed

    theorem induces_meta_adjunction:
    shows "meta_adjunction C D F G φ ψ"
      using φ_in_hom ψ_in_hom φ_ψ ψ_φ φ_natural D.comp_assoc
      by (unfold_locales, simp_all)

  end

  text‹
    A right adjoint functor induces a meta-adjunction, modulo the choice of a
    left adjoint and unit.
›

  context right_adjoint_functor
  begin

    definition Fo :: "'d  'c"
    where "Fo y = (SOME x. u. initial_arrow_to_functor C D G y x u)"

    definition ηo :: "'d  'd"
    where "ηo y = (SOME u. initial_arrow_to_functor C D G y (Fo y) u)"

    lemma Fo_ηo_initial:
    assumes "x u. initial_arrow_to_functor C D G y x u"
    shows "initial_arrow_to_functor C D G y (Fo y) (ηo y)"
      using assms Fo_def ηo_def
            someI_ex [of "λx. u. initial_arrow_to_functor C D G y x u"]
            someI_ex [of "λu. initial_arrow_to_functor C D G y (Fo y) u"]
      by simp

    text‹
      The left adjoint @{term F} to @{term g} takes each arrow @{term g} of
      @{term[source=true] D} to the unique @{term[source=true] C}-extension of
      @{term "D (ηo (D.cod g)) g"} along @{term "ηo (D.dom g)"}.
›

    definition F :: "'d  'c"
    where "F g = (if D.arr g then
                     initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (ηo (D.dom g))
                                  (Fo (D.cod g)) (ηo (D.cod g) D g)
                  else C.null)"

    lemma F_ide:
    assumes "D.ide y"
    shows "F y = Fo y"
    proof -
      interpret initial_arrow_to_functor C D G y ‹Fo y ‹ηo y
        using assms initial_arrows_exist Fo_ηo_initial by blast
      have 1: "arrow_to_functor C D G y (Fo y) (ηo y)" ..
      have "is_ext (Fo y) (ηo y) (Fo y)"
        unfolding is_ext_def using arrow D.comp_ide_arr [of "G (Fo y)" "ηo y"] by force
      hence "Fo y = the_ext (Fo y) (ηo y)" using 1 the_ext_unique by blast
      moreover have "ηo y = D (ηo (D.cod y)) y"
        using assms arrow D.comp_arr_ide D.comp_arr_dom by auto
      ultimately show ?thesis
        using assms F_def D.dom_cod D.in_homE D.ide_in_hom by metis
    qed

    lemma F_is_functor:
    shows "functor D C F"
    proof
      fix g :: 'd
      assume "¬D.arr g"
      thus "F g = C.null" using F_def by auto
      next
      fix g :: 'd
      assume g: "D.arr g"
      let ?y = "D.dom g"
      let ?y' = "D.cod g"
      interpret: initial_arrow_to_functor C D G ?y ‹Fo ?y ‹ηo ?y
        using g initial_arrows_exist Fo_ηo_initial by simp
      interpret y'η: initial_arrow_to_functor C D G ?y' ‹Fo ?y' ‹ηo ?y'
        using g initial_arrows_exist Fo_ηo_initial by simp
      have 1: "arrow_to_functor C D G ?y (Fo ?y') (D (ηo ?y') g)"
        using g y'η.arrow by (unfold_locales, auto)
      have "F g = yη.the_ext (Fo ?y') (D (ηo ?y') g)"
        using g F_def by simp
      hence Fg: "«F g : Fo ?y C Fo ?y'»  ηo ?y' D g = G (F g) D ηo ?y"
        using 1 yη.the_ext_prop by simp
      show "C.arr (F g)" using Fg by auto
      show "C.dom (F g) = F ?y" using Fg g F_ide by auto
      show "C.cod (F g) = F ?y'" using Fg g F_ide by auto
      next
      fix g :: 'd
      fix g' :: 'd
      assume g': "D.arr (D g' g)"
      have g: "D.arr g" using g' by auto
      let ?y = "D.dom g"
      let ?y' = "D.cod g"
      let ?y'' = "D.cod g'"
      interpret: initial_arrow_to_functor C D G ?y ‹Fo ?y ‹ηo ?y
        using g initial_arrows_exist Fo_ηo_initial by simp
      interpret y'η: initial_arrow_to_functor C D G ?y' ‹Fo ?y' ‹ηo ?y'
        using g initial_arrows_exist Fo_ηo_initial by simp
      interpret y''η: initial_arrow_to_functor C D G ?y'' ‹Fo ?y'' ‹ηo ?y''
        using g' initial_arrows_exist Fo_ηo_initial by auto
      have 1: "arrow_to_functor C D G ?y (Fo ?y') (ηo ?y' D g)"
        using g y'η.arrow by (unfold_locales, auto)
      have "F g = yη.the_ext (Fo ?y') (ηo ?y' D g)"
        using g F_def by simp
      hence Fg: "«F g : Fo ?y C Fo ?y'»  ηo ?y' D g = G (F g) D ηo ?y"
        using 1 yη.the_ext_prop by simp
      have 2: "arrow_to_functor C D G ?y' (Fo ?y'') (ηo ?y'' D g')"
        using g' y''η.arrow by (unfold_locales, auto)
      have "F g' = y'η.the_ext (Fo ?y'') (ηo ?y'' D g')"
        using g' F_def by auto
      hence Fg': "«F g' : Fo ?y' C Fo ?y''»  ηo ?y'' D g' = G (F g') D ηo ?y'"
        using 2 y'η.the_ext_prop by simp
      show "F (g' D g) = F g' C F g"
      proof -
        have "yη.is_ext (Fo ?y'') (ηo ?y'' D g' D g) (F g' C F g)"
        proof -
          have "«F g' C F g : Fo ?y C Fo ?y''»" using 1 2 Fg Fg' by auto
          moreover have "ηo ?y'' D g' D g = G (F g' C F g) D ηo ?y"
          proof -
            have "ηo ?y'' D g' D g = (G (F g') D ηo ?y') D g"
              using Fg' g g' y''η.arrow by (metis D.comp_assoc)
            also have "... =  G (F g') D ηo ?y' D g"
              using D.comp_assoc by fastforce
            also have "... = G (F g' C F g) D ηo ?y"
              using Fg Fg' D.comp_assoc by fastforce
            finally show ?thesis by auto
          qed
          ultimately show ?thesis using yη.is_ext_def by auto
        qed
        moreover have "arrow_to_functor C D G ?y (Fo ?y'') (ηo ?y'' D g' D g)"
          using g g' y''η.arrow by (unfold_locales, auto)
        ultimately show ?thesis
          using g g' F_def yη.the_ext_unique D.dom_comp D.cod_comp by auto
      qed
    qed

    interpretation F: "functor" D C F using F_is_functor by auto

    lemma F_simp:
    assumes "D.arr g"
    shows "F g = initial_arrow_to_functor.the_ext C D G (Fo (D.dom g)) (ηo (D.dom g))
                                                        (Fo (D.cod g)) (ηo (D.cod g) D g)"
      using assms F_def by simp

    interpretation FG: composite_functor D C D F G ..

    interpretation η: transformation_by_components D D D.map FG.map ηo
    proof
      fix y :: 'd
      assume y: "D.ide y"
      show "«ηo y : D.map y D FG.map y»"
      proof -
        interpret initial_arrow_to_functor C D G y ‹Fo y ‹ηo y
          using y Fo_ηo_initial initial_arrows_exist by simp
        show ?thesis using y F_ide arrow by auto
      qed
      next
      fix g :: 'd
      assume g: "D.arr g"
      show "ηo (D.cod g) D D.map g = FG.map g D ηo (D.dom g)"
      proof -
        let ?y = "D.dom g"
        let ?y' = "D.cod g"
        interpret: initial_arrow_to_functor C D G ?y ‹Fo ?y ‹ηo ?y
          using g Fo_ηo_initial initial_arrows_exist by simp
        interpret y'η: initial_arrow_to_functor C D G ?y' ‹Fo ?y' ‹ηo ?y'
          using g Fo_ηo_initial initial_arrows_exist by simp
        have "arrow_to_functor C D G ?y (Fo ?y') (ηo ?y' D g)"
          using g y'η.arrow by (unfold_locales, auto)
        moreover have "F g = yη.the_ext (Fo ?y') (ηo ?y' D g)"
          using g F_simp by blast
        ultimately have "yη.is_ext (Fo ?y') (ηo ?y' D g) (F g)"
          using yη.the_ext_prop yη.is_ext_def by auto
        thus ?thesis
          using g yη.is_ext_def by simp
      qed
    qed

    definition φ
    where "φ y h = D (G h) (η.map y)"

    lemma φ_in_hom:
    assumes y: "D.ide y" and f: "«f : F y C x»"
    shows "«φ y f : y D G x»"
      unfolding φ_def using assms η.maps_ide_in_hom by auto

    lemma φ_natural:
    assumes f: "«f : x C x'»" and g: "«g : y' D y»" and h: "«h : F y C x»"
    shows y' (f C h C F g) = (G f D φ y h) D g"
    proof -
      have "(G f D φ y h) D g = (G f D G h D η.map y) D g"
        unfolding φ_def by auto
      also have "... = (G f D G h) D η.map y D g"
        using D.comp_assoc by fastforce
      also have "... = G (f C h) D G (F g) D η.map y'"
        using f g h η.naturality by fastforce
      also have "... = (G (f C h) D G (F g)) D η.map y'"
        using D.comp_assoc by fastforce
      also have "... = G (f C h C F g) D η.map y'"
        using f g h D.comp_assoc by fastforce
      also have "... = φ y' (f C h C F g)"
        unfolding φ_def by auto
      finally show ?thesis by auto
    qed

    lemma φ_inverts_ext:
    assumes y: "D.ide y" and f: "«f : F y C x»"
    shows "arrow_to_functor.is_ext C D G (F y) (η.map y) x (φ y f) f"
    proof -
      interpret: arrow_to_functor C D G y ‹F y ‹η.map y
        using y η.maps_ide_in_hom by (unfold_locales, auto)
      show "yη.is_ext x (φ y f) f"
        using f y φ_def yη.is_ext_def F_ide by (unfold_locales, auto)
    qed

    lemma φ_invertible:
    assumes x: "C.ide x" and g: "«g : y D G x»"
    shows "∃!f. «f : F y C x»  φ y f = g"
    proof
      have y: "D.ide y" using g by auto
      interpret: initial_arrow_to_functor C D G y ‹Fo y ‹ηo y
        using y initial_arrows_exist Fo_ηo_initial by auto
      have 1: "arrow_to_functor C D G y x g"
        using x g by (unfold_locales, auto)
      let ?f = "yη.the_ext x g"
      have y ?f = g"
        using φ_def yη.the_ext_prop 1 F_ide x y φ_inverts_ext yη.is_ext_def by fastforce
      moreover have "«?f : F y C x»"
        using 1 y yη.the_ext_prop F_ide by simp
      ultimately show "«?f : F y C x»  φ y ?f = g" by auto
      show "f'. «f' : F y C x»  φ y f' = g  f' = ?f"
        using 1 y φ_inverts_ext yη.the_ext_unique F_ide by force
    qed

    definition ψ
    where "ψ x g = (THE f. «f : F (D.dom g) C x»  φ (D.dom g) f = g)"

    lemma ψ_in_hom:
    assumes "C.ide x" and "«g : y D G x»"
    shows "C.in_hom (ψ x g) (F y) x"
      using assms φ_invertible ψ_def theI' [of "λf. «f : F y C x»  φ y f = g"]
      by auto

    lemma ψ_φ:
    assumes "D.ide y" and "«f : F y C x»"
    shows x (φ y f) = f"
    proof -
      have "D.dom (φ y f) = y" using assms φ_in_hom by blast
      hence x (φ y f) = (THE f'. «f' : F y C x»  φ y f' = φ y f)"
        using ψ_def by auto
      moreover have "∃!f'. «f' : F y C x»  φ y f' = φ y f"
        using assms φ_in_hom φ_invertible C.ide_cod by blast
      ultimately show ?thesis using assms(2) by auto
    qed

    lemma φ_ψ:
    assumes "C.ide x" and "«g : y D G x»"
    shows y (ψ x g) = g"
      using assms φ_invertible ψ_def theI' [of "λf. «f : F y C x»  φ y f = g"]
      by auto

    theorem induces_meta_adjunction:
    shows "meta_adjunction C D F G φ ψ"
      using φ_in_hom ψ_in_hom φ_ψ ψ_φ φ_natural D.comp_assoc
      by (unfold_locales, auto)

  end

  section "Meta-Adjunctions Induce Hom-Adjunctions"

  text‹
    To obtain a hom-adjunction from a meta-adjunction, we need to exhibit hom-functors
    from @{term C} and @{term D} to a common set category @{term S}, so it is necessary
    to apply an actual concrete construction of such a category.
    We use the replete set category generated by the disjoint sum
    @{typ "('c+'d)"} of the arrow types of @{term C} and @{term D}.
›

  context meta_adjunction
  begin

    interpretation S: replete_setcat ‹undefined :: 'c+'d .

    definition inC :: "'c  ('c+'d) setcat.arr"
    where "inC  S.UP o Inl"

    definition inD :: "'d  ('c+'d) setcat.arr"
    where "inD  S.UP o Inr"

    interpretation Cop: dual_category C ..
    interpretation Dop: dual_category D ..
    interpretation CopxC: product_category Cop.comp C ..
    interpretation DopxD: product_category Dop.comp D ..
    interpretation DopxC: product_category Dop.comp C ..
    interpretation HomC: hom_functor C S.comp λ_. inC›
    proof
      show "f. C.arr f  inC f  S.Univ"
        unfolding inC_def using S.UP_mapsto by auto
      show "b a. C.ide b; C.ide a  inj_on inC (C.hom b a)"
        unfolding inC_def
        using S.inj_UP
        by (metis injD inj_Inl inj_compose inj_on_def)
    qed
    interpretation HomD: hom_functor D S.comp λ_. inD›
    proof
      show "f. D.arr f  inD f  S.Univ"
        unfolding inD_def using S.UP_mapsto by auto
      show "b a. D.ide b; D.ide a  inj_on inD (D.hom b a)"
        unfolding inD_def
        using S.inj_UP
        by (metis injD inj_Inr inj_compose inj_on_def)
    qed
    interpretation Fop: dual_functor D C F ..
    interpretation FopxC: product_functor Dop.comp C Cop.comp C Fop.map C.map ..
    interpretation DopxG: product_functor Dop.comp C Dop.comp D Dop.map G ..
    interpretation Hom_FopxC: composite_functor DopxC.comp CopxC.comp S.comp
                                                FopxC.map HomC.map ..
    interpretation Hom_DopxG: composite_functor DopxC.comp DopxD.comp S.comp
                                                DopxG.map HomD.map ..

    lemma inC_ψ [simp]:
    assumes "C.ide b" and "C.ide a" and "x  inC ` C.hom b a"
    shows "inC (HomC.ψ (b, a) x) = x"
      using assms by auto

    lemma ψ_inC [simp]:
    assumes "C.arr f"
    shows "HomC.ψ (C.dom f, C.cod f) (inC f) = f"
      using assms HomC.ψ_φ by blast

    lemma inD_ψ [simp]:
    assumes "D.ide b" and "D.ide a" and "x  inD ` D.hom b a"
    shows "inD (HomD.ψ (b, a) x) = x"
      using assms by auto

    lemma ψ_inD [simp]:
    assumes "D.arr f"
    shows "HomD.ψ (D.dom f, D.cod f) (inD f) = f"
      using assms HomD.ψ_φ by blast

    lemma Hom_FopxC_simp:
    assumes "DopxC.arr gf"
    shows "Hom_FopxC.map gf =
              S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
                      (HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))
                      (inC  (λh. snd gf C h C F (fst gf))
                            HomC.ψ (F (D.cod (fst gf)), C.dom (snd gf)))"
      using assms HomC.map_def by simp

    lemma Hom_DopxG_simp:
    assumes "DopxC.arr gf"
    shows "Hom_DopxG.map gf =
              S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
                      (HomD.set (D.dom (fst gf), G (C.cod (snd gf))))
                      (inD  (λh. G (snd gf) D h D fst gf)
                            HomD.ψ (D.cod (fst gf), G (C.dom (snd gf))))"
      using assms HomD.map_def by simp
                      
    definition Φo
    where "Φo yx = S.mkArr (HomC.set (F (fst yx), snd yx))
                           (HomD.set (fst yx, G (snd yx)))
                           (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))"

    lemma Φo_in_hom:
    assumes yx: "DopxC.ide yx"
    shows "«Φo yx : Hom_FopxC.map yx S Hom_DopxG.map yx»"
    proof -
      have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
        using yx HomC.map_ide by auto
      moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
        using yx HomD.map_ide by auto
      moreover have
          "«S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
                    (inD  φ (fst yx)  HomC.ψ (F (fst yx), snd yx)) :
              S.mkIde (HomC.set (F (fst yx), snd yx))
                 S S.mkIde (HomD.set (fst yx, G (snd yx)))»"
      proof (intro S.mkArr_in_hom)
        show "HomC.set (F (fst yx), snd yx)  S.Univ" using yx HomC.set_subset_Univ by simp
        show "HomD.set (fst yx, G (snd yx))  S.Univ" using yx HomD.set_subset_Univ by simp
        show "inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx)
                  HomC.set (F (fst yx), snd yx)  HomD.set (fst yx, G (snd yx))"
        proof
          fix x
          assume x: "x  HomC.set (F (fst yx), snd yx)"
          show "(inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx)) x
                   HomD.set (fst yx, G (snd yx))"
            using x yx HomC.ψ_mapsto [of "F (fst yx)" "snd yx"]
                  φ_in_hom [of "fst yx"] HomD.φ_mapsto [of "fst yx" "G (snd yx)"]
            by auto
        qed
      qed
      ultimately show ?thesis using Φo_def by auto
    qed

    interpretation Φ: transformation_by_components DopxC.comp S.comp
                                                   Hom_FopxC.map Hom_DopxG.map Φo
    proof
      fix yx
      assume yx: "DopxC.ide yx"
      show "«Φo yx : Hom_FopxC.map yx S Hom_DopxG.map yx»"
        using yx Φo_in_hom by auto
      next
      fix gf
      assume gf: "DopxC.arr gf"
      show "S.comp (Φo (DopxC.cod gf)) (Hom_FopxC.map gf)
                = S.comp (Hom_DopxG.map gf) (Φo (DopxC.dom gf))"
      proof -
        let ?g = "fst gf"
        let ?f = "snd gf"
        let ?x = "C.dom ?f"
        let ?x' = "C.cod ?f"
        let ?y = "D.cod ?g"
        let ?y' = "D.dom ?g"
        let ?Fy = "F ?y"
        let ?Fy' = "F ?y'"
        let ?Fg = "F ?g"
        let ?Gx = "G ?x"
        let ?Gx' = "G ?x'"
        let ?Gf = "G ?f"
        have 1: "S.arr (Hom_FopxC.map gf) 
                 Hom_FopxC.map gf = S.mkArr (HomC.set (?Fy, ?x)) (HomC.set (?Fy', ?x'))
                                            (inC o (λh. ?f C h C ?Fg) o HomC.ψ (?Fy, ?x))"
          using gf Hom_FopxC.preserves_arr Hom_FopxC_simp by blast
        have 2: "S.arr (Φo (DopxC.cod gf)) 
                 Φo (DopxC.cod gf) = S.mkArr (HomC.set (?Fy', ?x')) (HomD.set (?y', ?Gx'))
                                             (inD o φ ?y' o HomC.ψ (?Fy', ?x'))"
          using gf Φo_in_hom [of "DopxC.cod gf"] Φo_def [of "DopxC.cod gf"] φ_in_hom
                S.card_of_leq
          by auto
        have 3: "S.arr (Φo (DopxC.dom gf)) 
                 Φo (DopxC.dom gf) = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y, ?Gx))
                                             (inD o φ ?y o HomC.ψ (?Fy, ?x))"
          using gf Φo_in_hom [of "DopxC.dom gf"] Φo_def [of "DopxC.dom gf"] φ_in_hom
                S.card_of_leq
          by auto
        have 4: "S.arr (Hom_DopxG.map gf) 
                 Hom_DopxG.map gf = S.mkArr (HomD.set (?y, ?Gx)) (HomD.set (?y', ?Gx'))
                                            (inD o (λh. ?Gf D h D ?g) o HomD.ψ (?y, ?Gx))"
          using gf Hom_DopxG.preserves_arr Hom_DopxG_simp by blast
        have 5: "S.seq (Φo (DopxC.cod gf)) (Hom_FopxC.map gf) 
                 S.comp (Φo (DopxC.cod gf)) (Hom_FopxC.map gf)
                     = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                               ((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
                                 o (inC o (λh. ?f C h C ?Fg) o HomC.ψ (?Fy, ?x)))"
        proof -
          have "S.seq (Φo (DopxC.cod gf)) (Hom_FopxC.map gf)"
            using gf 1 2 Φo_in_hom Hom_FopxC.preserves_hom
            by (intro S.seqI', auto)
          thus ?thesis
            using S.comp_mkArr 1 2 by metis
        qed
        have 6: "S.comp (Hom_DopxG.map gf) (Φo (DopxC.dom gf))
                  = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                            ((inD o (λh. ?Gf D h D ?g) o HomD.ψ (?y, ?Gx))
                              o (inD o φ ?y o HomC.ψ (?Fy, ?x)))"
        proof -
          have "S.seq (Hom_DopxG.map gf) (Φo (DopxC.dom gf))"
            using gf 3 4 S.arr_mkArr S.cod_mkArr S.dom_mkArr
            by (intro S.seqI', auto)
          thus ?thesis
            using 3 4 S.comp_mkArr by metis
        qed
        have 7:
          "restrict ((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
                      o (inC o (λh. ?f C h C ?Fg) o HomC.ψ (?Fy, ?x))) (HomC.set (?Fy, ?x))
             = restrict ((inD o (λh. ?Gf D h D ?g) o HomD.ψ (?y, ?Gx))
                          o (inD o φ ?y o HomC.ψ (?Fy, ?x))) (HomC.set (?Fy, ?x))"
        proof (intro restrict_ext)
          show "h. h  HomC.set (?Fy, ?x) 
                     ((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
                       o (inC o (λh. ?f C h C ?Fg) o HomC.ψ (?Fy, ?x))) h
                       = ((inD o (λh. ?Gf D h D ?g) o HomD.ψ (?y, ?Gx))
                           o (inD o φ ?y o HomC.ψ (?Fy, ?x))) h"
          proof -
            fix h
            assume h: "h  HomC.set (?Fy, ?x)"
            have ψh: "«HomC.ψ (?Fy, ?x) h : ?Fy C ?x»"
              using gf h HomC.ψ_mapsto [of ?Fy ?x] CopxC.ide_char by auto
            show "((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
                       o (inC o (λh. ?f C h C ?Fg) o HomC.ψ (?Fy, ?x))) h
                       = ((inD o (λh. ?Gf D h D ?g) o HomD.ψ (?y, ?Gx))
                           o (inD o φ ?y o HomC.ψ (?Fy, ?x))) h"
            proof -
              have
                "((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
                   o (inC o (λh. ?f C h C ?Fg) o HomC.ψ (?Fy, ?x))) h
                   = inD (φ ?y' (HomC.ψ (?Fy', ?x') (inC (?f C HomC.ψ (?Fy, ?x) h C ?Fg))))"
                by simp
              also have "... = inD (φ ?y' (?f C HomC.ψ (?Fy, ?x) h C ?Fg))"
                using gf ψh HomC.φ_mapsto HomC.ψ_mapsto φ_in_hom
                      ψ_inC [of "?f C HomC.ψ (?Fy, ?x) h C ?Fg"]
                by auto
              also have "... = inD (D ?Gf (D (φ ?y (HomC.ψ (?Fy, ?x) h)) ?g))"
              proof -
                have "«?f : C.dom ?f  C.cod ?f»"
                  using gf by auto
                moreover have "«?g : D.dom ?g D D.cod ?g»"
                  using gf by auto
                ultimately show ?thesis
                  using gf ψh φ_in_hom G.preserves_hom C.in_homE D.in_homE
                        φ_naturality [of ?f ?x ?x' ?g ?y' ?y "HomC.ψ (?Fy, ?x) h"]
                  by simp
              qed
              also have "... =
                  inD (D ?Gf (D (HomD.ψ (?y, ?Gx) (inD (φ ?y (HomC.ψ (?Fy, ?x) h)))) ?g))"
                using gf ψh φ_in_hom by simp
              also have "... = ((inD o (λh. ?Gf D h D ?g) o HomD.ψ (?y, ?Gx))
                                o (inD o φ ?y o HomC.ψ (?Fy, ?x))) h"
                by simp
              finally show ?thesis by auto
            qed
          qed
        qed
        have 8: "S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                         ((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
                           o (inC o (λh. ?f C h C ?Fg) o HomC.ψ (?Fy, ?x)))
                    = S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                              ((inD o (λh. ?Gf D h D ?g) o HomD.ψ (?y, ?Gx))
                                o (inD o φ ?y o HomC.ψ (?Fy, ?x)))"
        proof (intro S.mkArr_eqI')
          show "S.arr (S.mkArr (HomC.set (?Fy, ?x)) (HomD.set (?y', ?Gx'))
                               ((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
                                o (inC o (λh. ?f C h C ?Fg) o HomC.ψ (?Fy, ?x))))"
            using 5 by metis
          show "t. t  HomC.set (?Fy, ?x) 
                      ((inD o φ ?y' o HomC.ψ (?Fy', ?x'))
                             o (inC o (λh. ?f C h C ?Fg) o HomC.ψ (?Fy, ?x))) t
                      = ((inD o (λh. ?Gf D h D ?g) o HomD.ψ (?y, ?Gx))
                              o (inD o φ ?y o HomC.ψ (?Fy, ?x))) t"
            using 7 restrict_apply by fast
        qed
        show ?thesis using 5 6 8 by auto
      qed
    qed

    lemma Φ_simp:
    assumes YX: "DopxC.ide yx"
    shows "Φ.map yx =
           S.mkArr (HomC.set (F (fst yx), snd yx)) (HomD.set (fst yx, G (snd yx)))
                   (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))"
      using YX Φo_def by simp
      
    abbreviation Ψo
    where "Ψo yx  S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
                            (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))"

    lemma Ψo_in_hom:
    assumes yx: "DopxC.ide yx"
    shows "«Ψo yx : Hom_DopxG.map yx S Hom_FopxC.map yx»"
    proof -
      have "Hom_FopxC.map yx = S.mkIde (HomC.set (F (fst yx), snd yx))"
        using yx HomC.map_ide by auto
      moreover have "Hom_DopxG.map yx = S.mkIde (HomD.set (fst yx, G (snd yx)))"
        using yx HomD.map_ide by auto
      moreover have "«Ψo yx : S.mkIde (HomD.set (fst yx, G (snd yx)))
                                 S S.mkIde (HomC.set (F (fst yx), snd yx))»"
      proof (intro S.mkArr_in_hom)
        show "HomC.set (F (fst yx), snd yx)  S.Univ" using yx HomC.set_subset_Univ by simp
        show "HomD.set (fst yx, G (snd yx))  S.Univ" using yx HomD.set_subset_Univ by simp
        show "inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx))
                  HomD.set (fst yx, G (snd yx))  HomC.set (F (fst yx), snd yx)"
        proof
          fix x
          assume x: "x  HomD.set (fst yx, G (snd yx))"
          show "(inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx))) x
                   HomC.set (F (fst yx), snd yx)"
            using x yx HomD.ψ_mapsto [of "fst yx" "G (snd yx)"] ψ_in_hom [of "snd yx"]
                  HomC.φ_mapsto [of "F (fst yx)" "snd yx"]
            by auto
        qed
      qed
      ultimately show ?thesis by auto
    qed

    lemma Φ_inv:
    assumes yx: "DopxC.ide yx"
    shows "S.inverse_arrows (Φ.map yx) (Ψo yx)"
    proof -
      have 1: "«Φ.map yx : Hom_FopxC.map yx S Hom_DopxG.map yx»"
        using yx Φ.preserves_hom [of yx yx yx] DopxC.ide_in_hom by blast
      have 2: "«Ψo yx : Hom_DopxG.map yx S Hom_FopxC.map yx»"
        using yx Ψo_in_hom by simp
      have 3: "Φ.map yx = S.mkArr (HomC.set (F (fst yx), snd yx))
                                   (HomD.set (fst yx, G (snd yx)))
                                   (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))"
        using yx Φ_simp by blast
      have antipar: "S.antipar (Φ.map yx) (Ψo yx)"
        using 1 2 by blast
      moreover have "S.ide (S.comp (Ψo yx) (Φ.map yx))"
      proof -
        have "S.comp (Ψo yx) (Φ.map yx) =
                  S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
                          ((inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))
                            o (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx)))"
          using 1 2 3 antipar S.comp_mkArr by auto
        also have
          "... = S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
                         (λx. x)"
        proof -
          have
            "S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx)) (λx. x)
               = ..."
          proof
            show
              "S.arr (S.mkArr (HomC.set (F (fst yx), snd yx)) (HomC.set (F (fst yx), snd yx))
                     (λx. x))"
              using yx HomC.set_subset_Univ S.arr_mkArr by simp
            show "x. x  HomC.set (F (fst yx), snd yx) 
                        x = ((inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))
                             o (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))) x"
            proof -
              fix x
              assume x: "x  HomC.set (F (fst yx), snd yx)"
              have "((inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))
                             o (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))) x
                      = inC (ψ (snd yx) (HomD.ψ (fst yx, G (snd yx))
                              (inD (φ (fst yx) (HomC.ψ (F (fst yx), snd yx) x)))))"
                by simp
              also have "... = inC (ψ (snd yx) (φ (fst yx) (HomC.ψ (F (fst yx), snd yx) x)))"
                using x yx HomC.ψ_mapsto [of "F (fst yx)" "snd yx"] φ_in_hom by force
              also have "... = inC (HomC.ψ (F (fst yx), snd yx) x)"
                using x yx HomC.ψ_mapsto [of "F (fst yx)" "snd yx"] ψ_φ by force
              also have "... = x" using x yx inC_ψ by simp
              finally show "x = ((inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))
                                   o (inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))) x"
                by auto
            qed
          qed
          thus ?thesis by auto
        qed
        also have "... = S.mkIde (HomC.set (F (fst yx), snd yx))"
          using yx S.mkIde_as_mkArr HomC.set_subset_Univ by force
        finally have
            "S.comp (Ψo yx) (Φ.map yx) = S.mkIde (HomC.set (F (fst yx), snd yx))"
          by auto
        thus ?thesis using yx HomC.set_subset_Univ S.ide_mkIde by simp
      qed
      moreover have "S.ide (S.comp (Φ.map yx) (Ψo yx))"
      proof -
        have "S.comp (Φ.map yx) (Ψo yx) =
                  S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
                          ((inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))
                            o (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx))))"
          using 1 2 3 S.comp_mkArr antipar by fastforce
        also
          have "... = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
                              (λx. x)"
        proof -
          have
            "S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx))) (λx. x)
                = ..."
          proof
            show
              "S.arr (S.mkArr (HomD.set (fst yx, G (snd yx))) (HomD.set (fst yx, G (snd yx)))
                     (λx. x))"
              using yx HomD.set_subset_Univ S.arr_mkArr by simp
            show "x. x  (HomD.set (fst yx, G (snd yx))) 
                        x = ((inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))
                            o (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))) x"
            proof -
              fix x
              assume x: "x  HomD.set (fst yx, G (snd yx))"
              have "((inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))
                          o (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))) x
                       = inD (φ (fst yx) (HomC.ψ (F (fst yx), snd yx)
                            (inC (ψ (snd yx) (HomD.ψ (fst yx, G (snd yx)) x)))))"
                by simp
              also have "... = inD (φ (fst yx) (ψ (snd yx) (HomD.ψ (fst yx, G (snd yx)) x)))"
             proof -
                have "«ψ (snd yx) (HomD.ψ (fst yx, G (snd yx)) x) : F (fst yx)  snd yx»"
                  using x yx HomD.ψ_mapsto [of "fst yx" "G (snd yx)"] ψ_in_hom by auto
                thus ?thesis by simp
              qed
              also have "... = inD (HomD.ψ (fst yx, G (snd yx)) x)"
                using x yx HomD.ψ_mapsto [of "fst yx" "G (snd yx)"] φ_ψ by force
              also have "... = x" using x yx inD_ψ by simp
              finally show "x = ((inD o φ (fst yx) o HomC.ψ (F (fst yx), snd yx))
                                   o (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))) x"
                by auto
            qed
          qed
          thus ?thesis by auto
        qed
        also have "... = S.mkIde (HomD.set (fst yx, G (snd yx)))"
          using yx S.mkIde_as_mkArr HomD.set_subset_Univ by force
        finally have
            "S.comp (Φ.map yx) (Ψo yx) = S.mkIde (HomD.set (fst yx, G (snd yx)))"
          by auto
        thus ?thesis using yx HomD.set_subset_Univ S.ide_mkIde by simp
      qed
      ultimately show ?thesis by auto
    qed

    interpretation Φ: natural_isomorphism DopxC.comp S.comp
                                          Hom_FopxC.map Hom_DopxG.map Φ.map
      apply (unfold_locales) using Φ_inv by blast

    interpretation Ψ: inverse_transformation DopxC.comp S.comp
                           Hom_FopxC.map Hom_DopxG.map Φ.map ..

    interpretation ΦΨ: inverse_transformations DopxC.comp S.comp
                           Hom_FopxC.map Hom_DopxG.map Φ.map Ψ.map
      using Ψ.inverts_components by (unfold_locales, simp)

    abbreviation Φ where "Φ  Φ.map"
    abbreviation Ψ where "Ψ  Ψ.map"

    abbreviation HomC where "HomC  HomC.map"
    abbreviation φC where "φC  λ_. inC"
    abbreviation HomD where "HomD  HomD.map"
    abbreviation φD where "φD  λ_. inD"

    theorem induces_hom_adjunction: "hom_adjunction C D S.comp φC φD F G Φ Ψ"
      using F.is_extensional by (unfold_locales, auto)

    lemma Ψ_simp:
    assumes yx: "DopxC.ide yx"
    shows yx = S.mkArr (HomD.set (fst yx, G (snd yx))) (HomC.set (F (fst yx), snd yx))
                          (inC o ψ (snd yx) o HomD.ψ (fst yx, G (snd yx)))"
      using assms Φo_def Φ_inv S.inverse_unique by simp

    text‹
      The original @{term φ} and @{term ψ} can be recovered from @{term Φ} and @{term Ψ}.
›

    interpretation Φ: set_valued_transformation DopxC.comp S.comp
                                                Hom_FopxC.map Hom_DopxG.map Φ.map ..
     
    interpretation Ψ: set_valued_transformation DopxC.comp S.comp
                                                Hom_DopxG.map Hom_FopxC.map Ψ.map ..

    lemma φ_in_terms_of_Φ':
    assumes y: "D.ide y" and f: "«f: F y C x»"
    shows "φ y f = (HomD.ψ (y, G x) o Φ.FUN (y, x) o inC) f"
    proof -
      have x: "C.ide x" using f by auto
      have 1: "S.arr (Φ (y, x))" using x y by fastforce
      have 2: (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                  (inD o φ y o HomC.ψ (F y, x))"
        using x y Φo_def by auto
      have "(HomD.ψ (y, G x) o Φ.FUN (y, x) o inC) f =
              HomD.ψ (y, G x)
                     (restrict (inD o φ y o HomC.ψ (F y, x)) (HomC.set (F y, x)) (inC f))"
        using 1 2 by simp
      also have "... = φ y f"
        using x y f HomC.φ_mapsto φ_in_hom HomC.ψ_mapsto C.ide_in_hom D.ide_in_hom
        by auto
      finally show ?thesis by auto
    qed

    lemma ψ_in_terms_of_Ψ':
    assumes x: "C.ide x" and g: "«g : y D G x»"
    shows "ψ x g = (HomC.ψ (F y, x) o Ψ.FUN (y, x) o inD) g"
    proof -
      have y: "D.ide y" using g by auto
      have 1: "S.arr (Ψ (y, x))"
        using x y Ψ.preserves_reflects_arr [of "(y, x)"] by simp
      have 2: (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                   (inC o ψ x o HomD.ψ (y, G x))"
        using x y Ψ_simp by force
      have "(HomC.ψ (F y, x) o Ψ.FUN (y, x) o inD) g =
              HomC.ψ (F y, x)
                     (restrict (inC o ψ x o HomD.ψ (y, G x)) (HomD.set (y, G x)) (inD g))"
        using 1 2 by simp
      also have "... = ψ x g"
        using x y g HomD.φ_mapsto ψ_in_hom HomD.ψ_mapsto C.ide_in_hom D.ide_in_hom
        by auto
      finally show ?thesis by auto
    qed

  end

  section "Hom-Adjunctions Induce Meta-Adjunctions"

  context hom_adjunction
  begin

    definition φ :: "'d  'c  'd"
    where
      "φ y h = (HomD.ψ (y, G (C.cod h)) o Φ.FUN (y, C.cod h) o φC (F y, C.cod h)) h"
    
    definition ψ :: "'c  'd  'c"
    where
      "ψ x h = (HomC.ψ (F (D.dom h), x) o Ψ.FUN (D.dom h, x) o φD (D.dom h, G x)) h"

    lemma Hom_FopxC_map_simp:
    assumes "DopxC.arr gf"
    shows "Hom_FopxC.map gf =
              S.mkArr (HomC.set (F (D.cod (fst gf)), C.dom (snd gf)))
                      (HomC.set (F (D.dom (fst gf)), C.cod (snd gf)))            
                      (φC (F (D.dom (fst gf)), C.cod (snd gf))
                           o (λh. snd gf C h C F (fst gf))
                           o HomC.ψ (F (D.cod (fst gf)), C.dom (snd gf)))"
      using assms HomC.map_def by simp

    lemma Hom_DopxG_map_simp:
    assumes "DopxC.arr gf"
    shows "Hom_DopxG.map gf =
              S.mkArr (HomD.set (D.cod (fst gf), G (C.dom (snd gf))))
                      (HomD.set (D.dom (fst gf), G (C.cod (snd gf))))           
                      (φD (D.dom (fst gf), G (C.cod (snd gf)))
                           o (λh. G (snd gf) D h D fst gf)
                           o HomD.ψ (D.cod (fst gf), G (C.dom (snd gf))))"
      using assms HomD.map_def by simp
                      
    lemma Φ_Fun_mapsto:
    assumes "D.ide y" and "«f : F y C x»"
    shows "Φ.FUN (y, x)  HomC.set (F y, x)  HomD.set (y, G x)"
    proof -
      have "S.arr (Φ (y, x))  Φ.DOM (y, x) = HomC.set (F y, x) 
                                Φ.COD (y, x) = HomD.set (y, G x)"
        using assms HomC.set_map HomD.set_map by auto
      thus ?thesis using S.Fun_mapsto by blast
    qed

    lemma φ_mapsto:
    assumes y: "D.ide y"
    shows y  C.hom (F y) x  D.hom y (G x)"
    proof
      fix h
      assume h: "h  C.hom (F y) x"
      hence 1: " «h : F y C x»" by simp
      show y h  D.hom y (G x)"
      proof -
        have "φC (F y, x) h  HomC.set (F y, x)"
          using y h 1 HomC.φ_mapsto [of "F y" x] by fastforce
        hence "Φ.FUN (y, x) (φC (F y, x) h)  HomD.set (y, G x)"
          using h y Φ_Fun_mapsto by auto
        thus ?thesis
          using y h 1 φ_def HomC.φ_mapsto HomD.ψ_mapsto [of y "G x"] by fastforce
      qed
    qed

    lemma Φ_simp:
    assumes "D.ide y" and "C.ide x"
    shows "S.arr (Φ (y, x))"
    and "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                            (φD (y, G x) o φ y o ψC (F y, x))"
    proof -
      show 1: "S.arr (Φ (y, x))" using assms by auto
      hence "Φ (y, x) = S.mkArr (Φ.DOM (y, x)) (Φ.COD (y, x)) (Φ.FUN (y, x))"
        using S.mkArr_Fun by metis
      also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (Φ.FUN (y, x))"
        using assms HomC.set_map HomD.set_map by fastforce
      also have "... = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                               (φD (y, G x) o φ y o ψC (F y, x))"
      proof (intro S.mkArr_eqI')
        show 2: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x)) (Φ.FUN (y, x)))"
          using 1 calculation by argo
        show "h. h  HomC.set (F y, x) 
                    Φ.FUN (y, x) h = (φD (y, G x) o φ y o ψC (F y, x)) h"
        proof -
          fix h
          assume h: "h  HomC.set (F y, x)"
          hence "«ψC (F y, x) h : F y C x»"
            using assms HomC.ψ_mapsto [of "F y" x] by auto
          hence "(φD (y, G x) o φ y o HomC.ψ (F y, x)) h =
                   φD (y, G x) (ψD (y, G x) (Φ.FUN (y, x) (φC (F y, x) (ψC (F y, x) h))))"
            using h φ_def by auto
          also have "... = φD (y, G x) (ψD (y, G x) (Φ.FUN (y, x) h))"
            using assms h HomC.φ_ψ Φ_Fun_mapsto by simp
          also have "... = Φ.FUN (y, x) h"
            using assms h Φ_Fun_mapsto [of y "ψC (F y, x) h"] HomC.ψ_mapsto
                  HomD.φ_ψ [of y "G x"] C.ide_in_hom D.ide_in_hom
            by (meson 2 G.preserves_ide S.arr_mkArr funcset_mem)
          finally show "Φ.FUN (y, x) h = (φD (y, G x) o φ y o ψC (F y, x)) h" by auto
        qed
      qed
      finally show "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                       (φD (y, G x) o φ y o ψC (F y, x))"
        by force
    qed

    lemma Ψ_Fun_mapsto:
    assumes "C.ide x" and "«g : y D G x»"
    shows "Ψ.FUN (y, x)  HomD.set (y, G x)  HomC.set (F y, x)"
    proof -
      have "S.arr (Ψ (y, x))  Ψ.COD (y, x) = HomC.set (F y, x) 
                                Ψ.DOM (y, x) = HomD.set (y, G x)"
        using assms HomC.set_map HomD.set_map by auto
      thus ?thesis using S.Fun_mapsto by fast
    qed

    lemma ψ_mapsto:
    assumes x: "C.ide x"
    shows x  D.hom y (G x)  C.hom (F y) x"
    proof
      fix h
      assume h: "h  D.hom y (G x)"
      hence 1: "«h : y D G x»" by auto
      show x h  C.hom (F y) x"
      proof -
        have "φD (y, G x) h  HomD.set (y, G x)"
          using x h 1 HomD.φ_mapsto [of y "G x"] by fastforce
        hence "Ψ.FUN (y, x) (φD (y, G x) h)  HomC.set (F y, x)"
          using h x Ψ_Fun_mapsto by auto
        thus ?thesis
          using x h 1 ψ_def HomD.φ_mapsto HomC.ψ_mapsto [of "F y" x] by fastforce
      qed
    qed

    lemma Ψ_simp:
    assumes "D.ide y" and "C.ide x"
    shows "S.arr (Ψ (y, x))"
    and "Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                            (φC (F y, x) o ψ x o ψD (y, G x))"
    proof -
      show 1: "S.arr (Ψ (y, x))" using assms by auto
      hence "Ψ (y, x) = S.mkArr (Ψ.DOM (y, x)) (Ψ.COD (y, x)) (Ψ.FUN (y, x))"
        using S.mkArr_Fun by metis
      also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (Ψ.FUN (y, x))"
        using assms HomC.set_map HomD.set_map by auto
      also have "... = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                               (φC (F y, x) o ψ x o ψD (y, G x))"
      proof (intro S.mkArr_eqI')
        show "S.arr (S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x)) (Ψ.FUN (y, x)))"
          using 1 calculation by argo
        show "h. h  HomD.set (y, G x) 
                    Ψ.FUN (y, x) h = (φC (F y, x) o ψ x o ψD (y, G x)) h"
        proof -
          fix h
          assume h: "h  HomD.set (y, G x)"
          hence "«ψD (y, G x) h : y D G x»"
            using assms HomD.ψ_mapsto [of y "G x"] by auto
          hence "(φC (F y, x) o ψ x o HomD.ψ (y, G x)) h =
                   φC (F y, x) (ψC (F y, x) (Ψ.FUN (y, x) (φD (y, G x) (ψD (y, G x) h))))"
            using h ψ_def by auto
          also have "... = φC (F y, x) (ψC (F y, x) (Ψ.FUN (y, x) h))"
            using assms h HomD.φ_ψ Ψ_Fun_mapsto by simp
          also have "... = Ψ.FUN (y, x) h"
            using assms h Ψ_Fun_mapsto HomD.ψ_mapsto [of y "G x"] HomC.φ_ψ [of "F y" x]
                  C.ide_in_hom D.ide_in_hom
            by blast
          finally show "Ψ.FUN (y, x) h = (φC (F y, x) o ψ x o HomD.ψ (y, G x)) h" by auto
        qed
      qed
      finally show "Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                       (φC (F y, x) o ψ x o ψD (y, G x))"
        by force
    qed

    text‹
      The length of the next proof stems from having to use properties of composition
      of arrows in @{term[source=true] S} to infer properties of the composition of the
      corresponding functions.
›

    interpretation φψ: meta_adjunction C D F G φ ψ
    proof
      fix y :: 'd and x :: 'c and h :: 'c
      assume y: "D.ide y" and h: "«h : F y C x»"
      have x: "C.ide x" using h by auto
      show "«φ y h : y D G x»"
      proof -
        have "Φ.FUN (y, x)  HomC.set (F y, x)  HomD.set (y, G x)"
          using y h Φ_Fun_mapsto by blast
        thus ?thesis
          using x y h φ_def HomD.ψ_mapsto [of y "G x"] HomC.φ_mapsto [of "F y" x] by auto
      qed
      show x (φ y h) = h"
      proof -
        have 0: "restrict (λh. h) (HomC.set (F y, x))
                   = restrict (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) (HomC.set (F y, x))"
        proof -
          have 1: "S.ide (Ψ (y, x) S Φ (y, x))"
            using x y ΦΨ.inv [of "(y, x)"] by auto
          hence 6: "S.seq (Ψ (y, x)) (Φ (y, x))" by auto
          have 2: "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                      (φD (y, G x) o φ y o ψC (F y, x)) 
                   Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                      (φC (F y, x) o ψ x o ψD (y, G x))"
            using x y Φ_simp Ψ_simp by force
          have 3: "S (Ψ (y, x)) (Φ (y, x))
                    = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                              (φC (F y, x) o (ψ x o φ y) o ψC (F y, x))"
          proof -
            have 4: "S.arr (Ψ (y, x) S Φ (y, x))" using 1 by auto
            hence "S (Ψ (y, x)) (Φ (y, x))
                     = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                               ((φC (F y, x) o ψ x o ψD (y, G x))
                                  o (φD (y, G x) o φ y o ψC (F y, x)))"
              using 1 2 S.ide_in_hom S.comp_mkArr by fastforce
            also have "... = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                     (φC (F y, x) o (ψ x o φ y) o ψC (F y, x))"
            proof (intro S.mkArr_eqI')
              show "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                   ((φC (F y, x) o ψ x o ψD (y, G x))
                                     o (φD (y, G x) o φ y o ψC (F y, x))))"
                using 4 calculation by simp
              show "h. h  HomC.set (F y, x) 
                          ((φC (F y, x) o ψ x o ψD (y, G x))
                            o (φD (y, G x) o φ y o ψC (F y, x))) h =
                          (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) h"
              proof -
                fix h
                assume h: "h  HomC.set (F y, x)"
                hence 1: "«φ y (ψC (F y, x) h) : y D G x»"
                  using x y h HomC.ψ_mapsto [of "F y" x] φ_mapsto by auto
                show "((φC (F y, x) o ψ x o ψD (y, G x))
                            o (φD (y, G x) o φ y o ψC (F y, x))) h =
                      (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) h"
                  using x y 1 φ_mapsto HomD.ψ_φ by simp
              qed
            qed
            finally show ?thesis by simp
          qed
          moreover have "Ψ (y, x) S Φ (y, x)
                             = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (λh. h)"
          proof -
            have "Ψ (y, x) S Φ (y, x) = S.dom (S (Ψ (y, x)) (Φ (y, x)))"
              using 1 by auto
            also have "... = S.dom (Φ (y, x))"
              using 1 S.dom_comp by blast
            finally show ?thesis
              using 2 6 S.mkIde_as_mkArr S.arr_mkArr by (elim S.seqE, auto)
          qed
          ultimately have 4: "S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                      (φC (F y, x) o (ψ x o φ y) o ψC (F y, x))
                                = S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x)) (λh. h)"
            by auto
          have 5: "S.arr (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                                  (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)))"
          proof -
            have "S.seq (Ψ (y, x)) (Φ (y, x))"
              using 1 by fast
            thus ?thesis using 3 by metis
          qed
          hence "restrict (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) (HomC.set (F y, x))
                  = S.Fun (S.mkArr (HomC.set (F y, x)) (HomC.set (F y, x))
                         (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)))"
            by auto
          also have "... = restrict (λh. h) (HomC.set (F y, x))"
            using 4 5 by auto
          finally show ?thesis by auto
        qed
        moreover have "φC (F y, x) h  HomC.set (F y, x)"
          using x y h HomC.φ_mapsto [of "F y" x] by auto
        ultimately have
            "φC (F y, x) h = (φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) (φC (F y, x) h)"
          using x y h HomC.φ_mapsto [of "F y" x] by fast
        hence "ψC (F y, x) (φC (F y, x) h) =
                 ψC (F y, x) ((φC (F y, x) o (ψ x o φ y) o ψC (F y, x)) (φC (F y, x) h))"
          by simp
        hence "h = ψC (F y, x) (φC (F y, x) (ψ x (φ y (ψC (F y, x) (φC (F y, x) h)))))"
          using x y h HomC.ψ_φ [of "F y" x] by simp
        also have "... = ψ x (φ y h)"
          using x y h HomC.ψ_φ HomC.ψ_φ φ_mapsto ψ_mapsto
          by (metis PiE mem_Collect_eq)
        finally show ?thesis by auto
      qed
      next
      fix x :: 'c and h :: 'd and y :: 'd
      assume x: "C.ide x" and h: "«h : y D G x»"
      have y: "D.ide y" using h by auto
      show "«ψ x h : F y C x»" using x y h ψ_mapsto [of x y] by auto
      show y (ψ x h) = h"
      proof -
        have 0: "restrict (λh. h) (HomD.set (y, G x))
                   = restrict (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) (HomD.set (y, G x))"
        proof -
          have 1: "S.ide (S (Φ (y, x)) (Ψ (y, x)))"
            using x y ΦΨ.inv by force
          hence 6: "S.seq (Φ (y, x)) (Ψ (y, x))" by auto
          have 2: "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                      (φD (y, G x) o φ y o ψC (F y, x)) 
                   Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                       (φC (F y, x) o ψ x o ψD (y, G x))"
            using x h Φ_simp Ψ_simp by auto
          have 3: "S (Φ (y, x)) (Ψ (y, x))
                     = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                               (φD (y, G x) o (φ y o ψ x) o ψD (y, G x))"
          proof -
            have 4: "S.seq (Φ (y, x)) (Ψ (y, x))" using 1 by auto
            hence "S (Φ (y, x)) (Ψ (y, x))
                     = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                               ((φD (y, G x) o φ y o ψC (F y, x))
                                 o (φC (F y, x) o ψ x o ψD (y, G x)))"
              using 1 2 6 S.ide_in_hom S.comp_mkArr by fastforce
            also have "... = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                     (φD (y, G x) o (φ y o ψ x) o ψD (y, G x))"
            proof
              show "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                   ((φD (y, G x) o φ y o ψC (F y, x))
                                     o (φC (F y, x) o ψ x o ψD (y, G x))))"
                using 4 calculation by simp
              show "h. h  HomD.set (y, G x) 
                          ((φD (y, G x) o φ y o ψC (F y, x))
                            o (φC (F y, x) o ψ x o ψD (y, G x))) h =
                          (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) h"
              proof -
                fix h
                assume h: "h  HomD.set (y, G x)"
                hence "«ψ x (ψD (y, G x) h) : F y C x»"
                  using x y HomD.ψ_mapsto [of y "G x"] ψ_mapsto by auto
                thus "((φD (y, G x) o φ y o ψC (F y, x))
                            o (φC (F y, x) o ψ x o ψD (y, G x))) h =
                      (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) h"
                  using x y HomC.ψ_φ by simp
              qed
            qed
            finally show ?thesis by auto
          qed
          moreover have "Φ (y, x) S Ψ (y, x) =
                           S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (λh. h)"
          proof -
            have "Φ (y, x) S Ψ (y, x) = S.dom (Φ (y, x) S Ψ (y, x))"
              using 1 by auto
            also have "... = S.dom (Ψ (y, x))"
              using 1 S.dom_comp by blast
            finally show ?thesis
              using 2 6 S.mkIde_as_mkArr S.arr_mkArr
              by (elim S.seqE, auto)
          qed
          ultimately have 4: "S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                      (φD (y, G x) o (φ y o ψ x) o ψD (y, G x))
                                = S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x)) (λh. h)"
            by auto
          have 5: "S.arr (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                                  (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)))"
            using 1 3 by fastforce
          hence "restrict (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) (HomD.set (y, G x))
                  = S.Fun (S.mkArr (HomD.set (y, G x)) (HomD.set (y, G x))
                         (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)))"
            by auto
          also have "... = restrict (λh. h) (HomD.set (y, G x))"
            using 4 5 by auto
          finally show ?thesis by auto
        qed
        moreover have "φD (y, G x) h  HomD.set (y, G x)"
          using x y h HomD.φ_mapsto [of y "G x"] by auto
        ultimately have
            "φD (y, G x) h = (φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) (φD (y, G x) h)"
          by fast
        hence "ψD (y, G x) (φD (y, G x) h) =
                ψD (y, G x) ((φD (y, G x) o (φ y o ψ x) o ψD (y, G x)) (φD (y, G x) h))"
          by simp
        hence "h = ψD (y, G x) (φD (y, G x) (φ y (ψ x (ψD (y, G x) (φD (y, G x) h)))))"
          using x y h HomD.ψ_φ by simp
        also have "... = φ y (ψ x h)"
          using x y h HomD.ψ_φ HomD.ψ_φ [of y (ψ x h)" y "G x"] φ_mapsto ψ_mapsto
          by fastforce
        finally show ?thesis by auto
      qed
      next
      fix x :: 'c and x' :: 'c and y :: 'd and y' :: 'd
      and f :: 'c and g :: 'd and h :: 'c
      assume f: "«f : x C x'»" and g: "«g : y' D y»" and h: "«h : F y C x»"
      have x: "C.ide x" using f by auto
      have y: "D.ide y" using g by auto
      have x': "C.ide x'" using f by auto
      have y': "D.ide y'" using g by auto
      show y' (f C h C F g) = G f D φ y h D g"
      proof -
        have 0: "restrict ((φD (y', G x') o (λh. G f D h D g) o ψD (y, G x))
                           o (φD (y, G x) o φ y o ψC (F y, x)))
                       (HomC.set (F y, x))
                = restrict ((φD (y', G x') o φ y' o ψC (F y', x'))
                             o (φC (F y', x') o (λh. f C h C F g)) o ψC (F y, x))
                           (HomC.set (F y, x))"
        proof -
          have 1: "S.arr (Φ (y, x)) 
                   Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                      (φD (y, G x) o φ y o ψC (F y, x))"
                using x y Φ_simp [of y x] by auto
          have 2: "S.arr (Φ (y', x')) 
                   Φ (y', x') = S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                        (φD (y', G x') o φ y' o ψC (F y', x'))"
                using x' y' Φ_simp [of y' x'] by auto
          have 3: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                  ((φD (y', G x') o (λh. G f D h D g) o ψD (y, G x))
                                    o (φD (y, G x) o φ y o ψC (F y, x))))
                    S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                             ((φD (y', G x') o (λh. G f D h D g) o ψD (y, G x))
                               o (φD (y, G x) o φ y o ψC (F y, x)))
                     = S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                  (φD (y', G x') o (λh. G f D h D g) o ψD (y, G x)))
                         (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                  (φD (y, G x) o φ y o ψC (F y, x)))"
          proof -
            have 1: "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                  (φD (y', G x') o (λh. G f D h D g) o ψD (y, G x)))
                           (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                  (φD (y, G x) o φ y o ψC (F y, x)))"
            proof -
              have "S.arr (Hom_DopxG.map (g, f)) 
                    Hom_DopxG.map (g, f)
                        = S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                  (φD (y', G x') o (λh. G f D h D g) o ψD (y, G x))"
                using f g Hom_DopxG.preserves_arr Hom_DopxG_map_simp by fastforce
              thus ?thesis
                using 1 S.cod_mkArr S.dom_mkArr S.seqI by metis
            qed
            have "S.seq (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                 (φD (y', G x') o (λh. G f D h D g) o ψD (y, G x)))
                        (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                 (φD (y, G x) o φ y o ψC (F y, x)))"
              using 1 by (intro S.seqI', auto)
            moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                             ((φD (y', G x') o (λh. G f D h D g) o ψD (y, G x))
                               o (φD (y, G x) o φ y o ψC (F y, x)))
                             = S (S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                          (φD (y', G x') o (λh. G f D h D g) o ψD (y, G x)))
                                 (S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                                          (φD (y, G x) o φ y o ψC (F y, x)))"
              using 1 S.comp_mkArr by fastforce
            ultimately show ?thesis by auto
          qed
          moreover have
             4: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                ((φD (y', G x') o φ y' o ψC (F y', x'))
                                  o (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x))))
                  S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                           ((φD (y', G x') o φ y' o ψC (F y', x'))
                             o (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x)))
                     = S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x')) 
                                  (φD (y', G x') o φ y' o ψC (F y', x')))
                         (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                  (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x)))"
          proof -
            have 5: "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                    (φD (y', G x') o φ y' o ψC (F y', x')))
                           (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                    (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x)))"
            proof -
              have "S.arr (Hom_FopxC.map (g, f)) 
                    Hom_FopxC.map (g, f)
                          = S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                    (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x))"
                using f g Hom_FopxC.preserves_arr Hom_FopxC_map_simp by fastforce
              thus ?thesis using 2 S.cod_mkArr S.dom_mkArr S.seqI by metis
            qed
            have "S.seq (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                 (φD (y', G x') o φ y' o ψC (F y', x')))
                        (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                 (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x)))"
              using 5 by (intro S.seqI', auto)
            moreover have "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                   ((φD (y', G x') o φ y' o ψC (F y', x'))
                                     o (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x)))
                             = S (S.mkArr (HomC.set (F y', x')) (HomD.set (y', G x'))
                                          (φD (y', G x') o φ y' o ψC (F y', x')))
                                 (S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                          (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x)))"
              using 5 S.comp_mkArr by fastforce
            ultimately show ?thesis by argo
          qed
          moreover have 2:
              "S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                       ((φD (y', G x') o (λh. G f D h D g) o ψD (y, G x))
                         o (φD (y, G x) o φ y o ψC (F y, x)))
                  = S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                            ((φD (y', G x') o φ y' o ψC (F y', x'))
                              o (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x)))"
          proof -
            have
              "S (Hom_DopxG.map (g, f)) (Φ (y, x)) = S (Φ (y', x')) (Hom_FopxC.map (g, f))"
              using f g Φ.is_natural_1 Φ.is_natural_2 by fastforce
            moreover have "Hom_DopxG.map (g, f)
                             = S.mkArr (HomD.set (y, G x)) (HomD.set (y', G x'))
                                       (φD (y', G x') o (λh. G f D h D g) o ψD (y, G x))"
              using f g Hom_DopxG_map_simp [of "(g, f)"] by fastforce
            moreover have "Hom_FopxC.map (g, f)
                             = S.mkArr (HomC.set (F y, x)) (HomC.set (F y', x'))
                                       (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x))"
              using f g Hom_FopxC_map_simp [of "(g, f)"] by fastforce
            ultimately show ?thesis using 1 2 3 4 by simp
          qed
          ultimately have 6: "S.arr (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                             ((φD (y', G x') o (λh. G f D h D g) o ψD (y, G x))
                                               o (φD (y, G x) o φ y o ψC (F y, x))))"
            by fast
          hence "restrict ((φD (y', G x') o (λh. D (G f) (D h g)) o ψD (y, G x))
                            o (φD (y, G x) o φ y o ψC (F y, x)))
                          (HomC.set (F y, x))
                  = S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                  ((φD (y', G x') o (λh. G f D h D g) o ψD (y, G x))
                                    o (φD (y, G x) o φ y o ψC (F y, x))))"
            by simp
          also have "... = S.Fun (S.mkArr (HomC.set (F y, x)) (HomD.set (y', G x'))
                                       ((φD (y', G x') o φ y' o ψC (F y', x'))
                                         o (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x))))"
            using 2 by argo
          also have "... = restrict ((φD (y', G x') o φ y' o ψC (F y', x'))
                                      o (φC (F y', x') o (λh. f C h C F g) o ψC (F y, x)))
                                    (HomC.set (F y, x))"
            using 4 S.Fun_mkArr by meson
          finally show ?thesis by auto
        qed
        hence 5: "((φD (y', G x')  (λh. G f D h D g)  ψD (y, G x))
                     (φD (y, G x)  φ y  ψC (F y, x))) (φC (F y, x) h) =
                   (φD (y', G x')  φ y'  ψC (F y', x')
                      (φC (F y', x')  (λh. f C h C F g))  ψC (F y, x)) (φC (F y, x) h)"
        proof -
          have "φC (F y, x) h  HomC.set (F y, x)"
            using x y h HomC.φ_mapsto [of "F y" x] by auto
          thus ?thesis
            using 0 h restr_eqE [of "(φD (y', G x')  (λh. G f D h D g)  ψD (y, G x))
                                       (φD (y, G x)  φ y  ψC (F y, x))"
                                    "HomC.set (F y, x)"
                                    "(φD (y', G x')  φ y'  ψC (F y', x'))
                                        (φC (F y', x')  (λh. f C h C F g) o ψC (F y, x))"]
            by fast
        qed
        show ?thesis
        proof -
          have y' (C f (C h (F g))) =
                  ψD (y', G x') (φD (y', G x') (φ y' (ψC (F y', x') (φC (F y', x')
                     (C f (C (ψC (F y, x) (φC (F y, x) h)) (F g)))))))"
          proof -
            have "ψD (y', G x') (φD (y', G x') (φ y' (ψC (F y', x') (φC (F y', x')
                     (C f (C (ψC (F y, x) (φC (F y, x) h)) (F g)))))))
                    = ψD (y', G x') (φD (y', G x') (φ y' (ψC (F y', x') (φC (F y', x')
                         (C f (C h (F g)))))))"
              using x y h HomC.ψ_φ by simp
            also have "... = ψD (y', G x') (φD (y', G x') (φ y' (C f (C h (F g)))))"
              using f g h HomC.ψ_φ [of "C f (C h (F g))"] by fastforce
            also have "... = φ y' (C f (C h (F g)))"
            proof -
              have "«φ y' (f C h C F g) : y' D G x'»"
                using f g h y' x' φ_mapsto [of y' x'] by auto
              thus ?thesis by simp
            qed
            finally show ?thesis by auto
          qed
          also have
             "... = ψD (y', G x')
                       (φD (y', G x')
                           (G f D ψD (y, G x) (φD (y, G x) (φ y (ψC (F y, x) (φC (F y, x) h))))
                                D g))"
            using 5 by force
          also have "... = D (G f) (D (φ y h) g)"
          proof -
            have φyh: "«φ y h : y D G x»"
              using x y h φ_mapsto by auto
            have "ψD (y', G x')
                     (φD (y', G x')
                         (G f D ψD (y, G x) (φD (y, G x) (φ y (ψC (F y, x) (φC (F y, x) h))))
                              D g)) =
                  ψD (y', G x') (φD (y', G x') (G f D ψD (y, G x) (φD (y, G x) (φ y h)) D g))"
              using x y f g h by auto
            also have "... = ψD (y', G x') (φD (y', G x') (G f D φ y h D g))"
              using φyh x' y' f g by simp
            also have "... = G f D φ y h D g"
            proof -
              have "«G f D φ y h D g : y' D G x'»"
                using x x' y' f g h φ_mapsto φyh by blast
              thus ?thesis
                using x y f g h φyh HomD.ψ_φ by auto
            qed
            finally show ?thesis by auto
          qed
          finally show ?thesis by auto
        qed
      qed
    qed

    theorem induces_meta_adjunction:
    shows "meta_adjunction C D F G φ ψ" ..

  end

  section "Putting it All Together"

  text‹
    Combining the above results, an interpretation of any one of the locales:
    left_adjoint_functor›, right_adjoint_functor›, meta_adjunction›,
    hom_adjunction›, and unit_counit_adjunction› extends to an interpretation
    of adjunction›.
›

  context meta_adjunction
  begin

    interpretation F: left_adjoint_functor D C F using has_left_adjoint_functor by auto
    interpretation G: right_adjoint_functor C D G using has_right_adjoint_functor by auto

    interpretation ηε: unit_counit_adjunction C D F G η ε
      using induces_unit_counit_adjunction η_def ε_def by auto
    interpretation ΦΨ: hom_adjunction C D replete_setcat.comp φC φD F G Φ Ψ
      using induces_hom_adjunction by auto

    theorem induces_adjunction:
    shows "adjunction C D replete_setcat.comp φC φD F G φ ψ η ε Φ Ψ"
      apply (unfold_locales)
      using ε_map_simp η_map_simp φ_in_terms_of_η φ_in_terms_of_Φ' ψ_in_terms_of_ε
            ψ_in_terms_of_Ψ' Φ_simp Ψ_simp η_def ε_def
      by auto

  end

  context unit_counit_adjunction
  begin

    interpretation φψ: meta_adjunction C D F G φ ψ using induces_meta_adjunction by auto

    interpretation F: left_adjoint_functor D C F using φψ.has_left_adjoint_functor by auto
    interpretation G: right_adjoint_functor C D G using φψ.has_right_adjoint_functor by auto

    interpretation ΦΨ: hom_adjunction C D replete_setcat.comp
                          φψ.φC φψ.φD F G φψ.Φ φψ.Ψ
      using φψ.induces_hom_adjunction by auto

    theorem induces_adjunction:
    shows "adjunction C D replete_setcat.comp φψ.φC φψ.φD F G φ ψ η ε φψ.Φ φψ.Ψ"
      using ε_in_terms_of_ψ η_in_terms_of_φ φψ.φ_in_terms_of_Φ' ψ_def φψ.ψ_in_terms_of_Ψ'
            φψ.Φ_simp φψ.Ψ_simp φ_def
      apply (unfold_locales)
      by auto

  end

  context hom_adjunction
  begin
   
    interpretation φψ: meta_adjunction C D F G φ ψ
      using induces_meta_adjunction by auto
    interpretation F: left_adjoint_functor D C F using φψ.has_left_adjoint_functor by auto
    interpretation G: right_adjoint_functor C D G using φψ.has_right_adjoint_functor by auto
    interpretation ηε: unit_counit_adjunction C D F G φψ.η φψ.ε
      using φψ.induces_unit_counit_adjunction φψ.η_def φψ.ε_def by auto

    theorem induces_adjunction:
    shows "adjunction C D S φC φD F G φ ψ φψ.η φψ.ε Φ Ψ"
    proof
      fix x
      assume "C.ide x"
      thus "φψ.ε x = ψ x (G x)" using φψ.ε_map_simp φψ.ε_def by simp
      next
      fix y
      assume "D.ide y"
      thus "φψ.η y = φ y (F y)" using φψ.η_map_simp φψ.η_def by simp
      fix x y f
      assume y: "D.ide y" and f: "«f : F y C x»"
      show y f = G f D φψ.η y" using y f φψ.φ_in_terms_of_η φψ.η_def by simp
      show y f = (ψD (y, G x)  Φ.FUN (y, x)  φC (F y, x)) f" using y f φ_def by auto
      next
      fix x y g
      assume x: "C.ide x" and g: "«g : y D G x»"
      show x g = φψ.ε x C F g" using x g φψ.ψ_in_terms_of_ε φψ.ε_def by simp
      show x g = (ψC (F y, x)  Ψ.FUN (y, x)  φD (y, G x)) g" using x g ψ_def by fast
      next
      fix x y
      assume x: "C.ide x" and y: "D.ide y"
      show "Φ (y, x) = S.mkArr (HomC.set (F y, x)) (HomD.set (y, G x))
                               (φD (y, G x) o φ y o ψC (F y, x))"
        using x y Φ_simp by simp
      show "Ψ (y, x) = S.mkArr (HomD.set (y, G x)) (HomC.set (F y, x))
                                (φC (F y, x) o ψ x o ψD (y, G x))"
        using x y Ψ_simp by simp
    qed

  end

  context left_adjoint_functor
  begin

    interpretation φψ: meta_adjunction C D F G φ ψ
      using induces_meta_adjunction by auto

    theorem induces_adjunction:
    shows "adjunction C D replete_setcat.comp φψ.φC φψ.φD F G φ ψ φψ.η φψ.ε φψ.Φ φψ.Ψ"
      using φψ.induces_adjunction by auto

  end

  context right_adjoint_functor
  begin

    interpretation φψ: meta_adjunction C D F G φ ψ
      using induces_meta_adjunction by auto

    theorem induces_adjunction:
    shows "adjunction C D replete_setcat.comp φψ.φC φψ.φD F G φ ψ φψ.η φψ.ε φψ.Φ φψ.Ψ"
      using φψ.induces_adjunction by auto

  end

  definition adjoint_functors
  where "adjoint_functors C D F G = (φ ψ. meta_adjunction C D F G φ ψ)"

  lemma adjoint_functors_respects_naturally_isomorphic:
  assumes "adjoint_functors C D F G"
  and "naturally_isomorphic D C F' F" and "naturally_isomorphic C D G G'"
  shows "adjoint_functors C D F' G'"
  proof -
    obtain φ ψ where φψ: "meta_adjunction C D F G φ ψ"
      using assms(1) adjoint_functors_def by blast
    interpret φψ: meta_adjunction C D F G φ ψ
      using φψ by simp
    obtain τ where τ: "natural_isomorphism D C F' F τ"
      using assms(2) naturally_isomorphic_def by blast
    obtain μ where μ: "natural_isomorphism C D G G' μ"
      using assms(3) naturally_isomorphic_def by blast
    show ?thesis
      using adjoint_functors_def τ μ φψ.respects_natural_isomorphism by blast
  qed

  lemma left_adjoint_functor_respects_naturally_isomorphic:
  assumes "left_adjoint_functor D C F"
  and "naturally_isomorphic D C F F'"
  shows "left_adjoint_functor D C F'"
  proof -
    interpret F: left_adjoint_functor D C F
      using assms(1) by simp
    have 1: "meta_adjunction C D F F.G F.φ F.ψ"
      using F.induces_meta_adjunction by simp
    interpret φψ: meta_adjunction C D F F.G F.φ F.ψ
      using 1 by simp
    have "adjoint_functors C D F F.G"
      using 1 adjoint_functors_def by blast
    hence 2: "adjoint_functors C D F' F.G"
      using assms(2) adjoint_functors_respects_naturally_isomorphic [of C D F F.G F' F.G]
            naturally_isomorphic_reflexive naturally_isomorphic_symmetric
            φψ.G.functor_axioms
      by blast
    obtain φ' ψ' where φ'ψ': "meta_adjunction C D F' F.G φ' ψ'"
      using 2 adjoint_functors_def by blast
    interpret φ'ψ': meta_adjunction C D F' F.G φ' ψ'
      using φ'ψ' by simp
    show ?thesis
      using φ'ψ'.has_left_adjoint_functor by simp
  qed

  lemma right_adjoint_functor_respects_naturally_isomorphic:
  assumes "right_adjoint_functor C D G"
  and "naturally_isomorphic C D G G'"
  shows "right_adjoint_functor C D G'"
  proof -
    interpret G: right_adjoint_functor C D G
      using assms(1) by simp
    have 1: "meta_adjunction C D G.F G G.φ G.ψ"
      using G.induces_meta_adjunction by simp
    interpret φψ: meta_adjunction C D G.F G G.φ G.ψ
      using 1 by simp
    have "adjoint_functors C D G.F G"
      using 1 adjoint_functors_def by blast
    hence 2: "adjoint_functors C D G.F G'"
      using assms(2) adjoint_functors_respects_naturally_isomorphic
            naturally_isomorphic_reflexive naturally_isomorphic_symmetric
            φψ.F.functor_axioms
      by blast
    obtain φ' ψ' where φ'ψ': "meta_adjunction C D G.F G' φ' ψ'"
      using 2 adjoint_functors_def by blast
    interpret φ'ψ': meta_adjunction C D G.F G' φ' ψ'
      using φ'ψ' by simp
    show ?thesis
      using φ'ψ'.has_right_adjoint_functor by simp
  qed

  section "Inverse Functors are Adjoints"

  (* TODO: This really should show that inverse functors induce an adjoint equivalence. *)

  lemma inverse_functors_induce_meta_adjunction:
  assumes "inverse_functors C D F G"
  shows "meta_adjunction C D F G (λx. G) (λy. F)"
  proof -
    interpret inverse_functors C D F G using assms by auto
    interpret meta_adjunction C D F G λx. G λy. F
    proof -
      have 1: "y. B.arr y  G (F y) = y"
      proof -
        fix y
        assume y: "B.arr y"
        have "G (F y) = (G o F) y" by simp
        thus "G (F y) = y" using y inv B.map_def by simp
      qed
      have 2: "x. A.arr x  F (G x) = x"
      proof -
        fix x
        assume x: "A.arr x"
        have "F (G x) = (F o G) x" by simp
        thus "F (G x) = x" using x inv' A.map_def by simp
      qed
      show "meta_adjunction C D F G (λx. G) (λy. F)"
      proof
        fix y f x
        assume y: "B.ide y" and f: "«f : F y A x»"
        show "«G f : y B G x»" using y f 1 G.preserves_hom by (elim A.in_homE, auto)
        show "F (G f) = f" using f 2 by auto
        next
        fix x g y
        assume x: "A.ide x" and g: "«g : y B G x»"
        show "«F g : F y A x»" using x g 2 F.preserves_hom by (elim B.in_homE, auto)
        show "G (F g) = g" using g 1 A.map_def by blast
        next
        fix f x x' g y' y h
        assume f: "«f : x A x'»" and g: "«g : y' B y»" and h: "«h : F y A x»"
        show "G (C f (C h (F g))) = D (G f) (D (G h) g)"
          using f g h 1 2 inv inv' A.map_def B.map_def by (elim A.in_homE B.in_homE, auto)
      qed
    qed
    show ?thesis ..
  qed

  lemma inverse_functors_are_adjoints:
  assumes "inverse_functors A B F G"
  shows "adjoint_functors A B F G"
    using assms inverse_functors_induce_meta_adjunction adjoint_functors_def by fast

  context inverse_functors
  begin

    lemma η_char:
    shows "meta_adjunction.η B F (λx. G) = identity_functor.map B"
    proof (intro eqI)
      interpret meta_adjunction A B F G λy. G λx. F
        using inverse_functors_induce_meta_adjunction inverse_functors_axioms by auto
      interpret adjunction A B replete_setcat.comp φC φD F G λy. G λx. F η ε Φ Ψ
        using induces_adjunction by simp
      show "natural_transformation B B B.map GF.map η"
        using η.natural_transformation_axioms by auto
      show "natural_transformation B B B.map GF.map B.map"
      proof -
        have "natural_transformation B B B.map B.map B.map" ..
        moreover have "GF.map = B.map" using inv by auto
        ultimately show ?thesis by auto
      qed
      fix b
      show "B.ide b  η b = B.map b"
      proof -
        assume b: "B.ide b"
        have b = GF.map b" using b η_map_simp η_def by simp
        also have "... = B.map b" using b inv B.map_def by simp
        finally show b = B.map b" by auto
      qed
    qed

    lemma ε_char:
    shows "meta_adjunction.ε A F G (λy. F) = identity_functor.map A"
    proof (intro eqI)
      interpret meta_adjunction A B F G λy. G λx. F
        using inverse_functors_induce_meta_adjunction inverse_functors_axioms by auto
      interpret adjunction A B replete_setcat.comp φC φD F G λy. G λx. F η ε Φ Ψ
        using induces_adjunction by simp
      show "natural_transformation A A FG.map A.map ε"
        using ε.natural_transformation_axioms by auto
      show "natural_transformation A A FG.map A.map A.map"
      proof -
        have "natural_transformation A A A.map A.map A.map" ..
        moreover have "FG.map = A.map" using inv' by auto
        ultimately show ?thesis by auto
      qed
      fix a
      show "A.ide a  ε a = A.map a"
      proof -
        assume a: "A.ide a"
        have a = FG.map a" using a ε_map_simp ε_def by simp
        also have "... = A.map a" using a inv' A.map_def by simp
        finally show a = A.map a" by auto
      qed
    qed

  end

  section "Composition of Adjunctions"

  locale composite_adjunction =
    A: category A +
    B: category B +
    C: category C +
    F: "functor" B A F +
    G: "functor" A B G +
    F': "functor" C B F' +
    G': "functor" B C G' +
    FG: meta_adjunction A B F G φ ψ +
    F'G': meta_adjunction B C F' G' φ' ψ'
  for A :: "'a comp"     (infixr "A" 55)
  and B :: "'b comp"     (infixr "B" 55)
  and C :: "'c comp"     (infixr "C" 55)
  and F :: "'b  'a"
  and G :: "'a  'b"
  and F' :: "'c  'b"
  and G' :: "'b  'c"
  and φ :: "'b  'a  'b"
  and ψ :: "'a  'b  'a"
  and φ' :: "'c  'b  'c"
  and ψ' :: "'b  'c  'b"
  begin

    interpretation FG: adjunction A B replete_setcat.comp
                           FG.φC FG.φD F G φ ψ FG.η FG.ε FG.Φ FG.Ψ
      using FG.induces_adjunction by simp
    interpretation F'G': adjunction B C replete_setcat.comp F'G'.φC F'G'.φD F' G' φ' ψ'
                           F'G'.η F'G'.ε F'G'.Φ F'G'.Ψ
      using F'G'.induces_adjunction by simp

    (* Notation for C.in_hom is inherited here somehow, but I don't know from where. *)

    lemma is_meta_adjunction:
    shows "meta_adjunction A C (F o F') (G' o G) (λz. φ' z o φ (F' z)) (λx. ψ x o ψ' (G x))"
    proof -
      interpret G'oG: composite_functor A B C G G' ..
      interpret FoF': composite_functor C B A F' F ..
      show ?thesis
      proof
        fix y f x
        assume y: "C.ide y" and f: "«f : FoF'.map y A x»"
        show "«(φ' y  φ (F' y)) f : y C G'oG.map x»"
          using y f FG.φ_in_hom F'G'.φ_in_hom by simp
        show "(ψ x  ψ' (G x)) ((φ' y  φ (F' y)) f) = f"
          using y f FG.φ_in_hom F'G'.φ_in_hom FG.ψ_φ F'G'.ψ_φ by simp
        next
        fix x g y
        assume x: "A.ide x" and g: "«g : y C G'oG.map x»"
        show "«(ψ x  ψ' (G x)) g : FoF'.map y A x»"
          using x g FG.ψ_in_hom F'G'.ψ_in_hom by auto
        show "(φ' y  φ (F' y)) ((ψ x  ψ' (G x)) g) = g"
          using x g FG.ψ_in_hom F'G'.ψ_in_hom FG.φ_ψ F'G'.φ_ψ by simp
        next
        fix f x x' g y' y h
        assume f: "«f : x A x'»" and g: "«g : y' C y»" and h: "«h : FoF'.map y A x»"
        show "(φ' y'  φ (F' y')) (f A h A FoF'.map g) =
              G'oG.map f C (φ' y  φ (F' y)) h C g"
          using f g h FG.φ_naturality [of f x x' "F' g" "F' y'" "F' y" h]
                F'G'.φ_naturality [of "G f" "G x" "G x'" g y' y "φ (F' y) h"]
                FG.φ_in_hom
          by fastforce
      qed
    qed

    interpretation KηH: natural_transformation C C G' o F' G' o G o F o F'
                          G' o FG.η o F'
    proof -
      interpret ηF': natural_transformation C B F' (G o F) o F' ‹FG.η o F'
        using FG.η_is_natural_transformation F'.natural_transformation_axioms
              horizontal_composite
        by fastforce
      interpret G'ηF': natural_transformation C C G' o F' G' o (G o F o F')
                         G' o (FG.η o F')
        using ηF'.natural_transformation_axioms G'.natural_transformation_axioms
              horizontal_composite
        by blast
      show "natural_transformation C C (G' o F') (G' o G o F o F') (G' o FG.η o F')"
        using G'ηF'.natural_transformation_axioms o_assoc by metis
    qed
    interpretation G'ηF'oη': vertical_composite C C C.map G' o F' G' o G o F o F'
                             F'G'.η G' o FG.η o F' ..

    interpretation FεG: natural_transformation A A F o F' o G' o G F o G
                          F o F'G'.ε o G
    proof -
      interpret Fε': natural_transformation B A F o (F' o G') F F o F'G'.ε›
        using F'G'.ε.natural_transformation_axioms F.natural_transformation_axioms
              horizontal_composite
        by fastforce
      interpret Fε'G: natural_transformation A A F o (F' o G') o G F o G F o F'G'.ε o G
        using Fε'.natural_transformation_axioms G.natural_transformation_axioms
              horizontal_composite
        by blast
      show "natural_transformation A A (F o F' o G' o G) (F o G) (F o F'G'.ε o G)"
        using Fε'G.natural_transformation_axioms o_assoc by metis
    qed
    interpretation εoFε'G: vertical_composite A A F  F'  G'  G F o G A.map
                             F o F'G'.ε o G FG.ε ..

    interpretation meta_adjunction A C F o F' G' o G
                                   λz. φ' z o φ (F' z) λx. ψ x o ψ' (G x)
      using is_meta_adjunction by auto
    interpretation adjunction A C replete_setcat.comp φC φD F  F' G'  G
                     λz. φ' z  φ (F' z) λx. ψ x  ψ' (G x) η ε Φ Ψ
      using induces_adjunction by simp

    lemma η_char:
    shows = G'ηF'oη'.map"
    proof (intro NaturalTransformation.eqI)
      show "natural_transformation C C C.map (G' o G o F o F') G'ηF'oη'.map" ..
      show "natural_transformation C C C.map (G' o G o F o F') η"
      proof -
        have "natural_transformation C C C.map ((G'  G)  (F  F')) η" ..
        moreover have "(G' o G) o (F o F') = G' o G o F o F'" by auto
        ultimately show ?thesis by metis
      qed
      fix a
      assume a: "C.ide a"
      show a = G'ηF'oη'.map a"
        unfolding η_def
        using a G'ηF'oη'.map_def FG.η.preserves_hom [of "F' a" "F' a" "F' a"]
              F'G'.φ_in_terms_of_η FG.η_map_simp η_map_simp [of a] C.ide_in_hom
              F'G'.η_def FG.η_def
        by auto
    qed

    lemma ε_char:
    shows = εoFε'G.map"
    proof (intro NaturalTransformation.eqI)
      show "natural_transformation A A (F o F' o G' o G) A.map ε"
      proof -
        have "natural_transformation A A ((F  F')  (G'  G)) A.map ε" ..
        moreover have "(F o F') o (G' o G) = F o F' o G' o G" by auto
        ultimately show ?thesis by metis
      qed
      show "natural_transformation A A (F  F'  G'  G) A.map εoFε'G.map" ..
      fix a
      assume a: "A.ide a"
      show a = εoFε'G.map a"
      proof -
        have a = ψ a (ψ' (G a) (G' (G a)))"
          using a ε_in_terms_of_ψ by simp
        also have "... = FG.ε a A F (F'G'.ε (G a) B F' (G' (G a)))"
          unfolding ε_def
          using a F'G'.ψ_in_terms_of_ε [of "G a" "G' (G a)" "G' (G a)"]
                F'G'.ε.preserves_hom [of "G a" "G a" "G a"]
                FG.ψ_in_terms_of_ε [of a "F'G'.ε (G a) B F' (G' (G a))" "(F'G'.FG.map (G a))"]
                F'G'.ε_def FG.ε_def
          by fastforce
        also have "... = εoFε'G.map a"
          using a B.comp_arr_dom εoFε'G.map_def by simp
        finally show ?thesis by blast
      qed
    qed

  end

  section "Right Adjoints are Unique up to Natural Isomorphism"

  text‹
    As an example of the use of the of the foregoing development, we show that two right adjoints
    to the same functor are naturally isomorphic.
›

  theorem two_right_adjoints_naturally_isomorphic:
  assumes "adjoint_functors C D F G" and "adjoint_functors C D F G'"
  shows "naturally_isomorphic C D G G'"
  proof -
    text‹
      For any object @{term x} of @{term C}, we have that ε x ∈ C.hom (F (G x)) x›
      is a terminal arrow from @{term F} to @{term x}, and similarly for ε' x›.
      We may therefore obtain the unique coextension τ x ∈ D.hom (G x) (G' x)›
      of ε x› along ε' x›.
      An explicit formula for τ x› is D (G' (ε x)) (η' (G x))›.
      Similarly, we obtain τ' x = D (G (ε' x)) (η (G' x)) ∈ D.hom (G' x) (G x)›.
      We show these are the components of inverse natural transformations between
      @{term G} and @{term G'}.
›
    obtain φ ψ where φψ: "meta_adjunction C D F G φ ψ"
      using assms adjoint_functors_def by blast
    obtain φ' ψ' where φ'ψ': "meta_adjunction C D F G' φ' ψ'"
      using assms adjoint_functors_def by blast
    interpret Adj: meta_adjunction C D F G φ ψ using φψ by auto
    interpret Adj: adjunction C D replete_setcat.comp Adj.φC Adj.φD
                              F G φ ψ Adj.η Adj.ε Adj.Φ Adj.Ψ
      using Adj.induces_adjunction by auto
    interpret Adj': meta_adjunction C D F G' φ' ψ' using φ'ψ' by auto
    interpret Adj': adjunction C D replete_setcat.comp Adj'.φC Adj'.φD
                               F G' φ' ψ' Adj'.η Adj'.ε Adj'.Φ Adj'.Ψ
      using Adj'.induces_adjunction by auto
    write C (infixr "C" 55)
    write D (infixr "D" 55)
    write Adj.C.in_hom ("«_ : _ C _»")
    write Adj.D.in_hom ("«_ : _ D _»")
    let ?τo = "λa. G' (Adj.ε a) D Adj'.η (G a)"
    interpret τ: transformation_by_components C D G G' ?τo
    proof
      show "a. Adj.C.ide a  «G' (Adj.ε a) D Adj'.η (G a) : G a D G' a»"
        by fastforce
      show "f. Adj.C.arr f 
                   (G' (Adj.ε (Adj.C.cod f)) D Adj'.η (G (Adj.C.cod f))) D G f =
                   G' f D G' (Adj.ε (Adj.C.dom f)) D Adj'.η (G (Adj.C.dom f))"
      proof -
        fix f
        assume f: "Adj.C.arr f"
        let ?x = "Adj.C.dom f"
        let ?x' = "Adj.C.cod f"
        have "(G' (Adj.ε (Adj.C.cod f)) D Adj'.η (G (Adj.C.cod f))) D G f =
              G' (Adj.ε (Adj.C.cod f) C F (G f)) D Adj'.η (G (Adj.C.dom f))"
          using f Adj'.η.naturality [of "G f"] Adj.D.comp_assoc by simp
        also have "... = G' (f C Adj.ε (Adj.C.dom f)) D Adj'.η (G (Adj.C.dom f))"
          using f Adj.ε.naturality by simp
        also have "... = G' f D G' (Adj.ε (Adj.C.dom f)) D Adj'.η (G (Adj.C.dom f))"
          using f Adj.D.comp_assoc by simp
        finally show "(G' (Adj.ε (Adj.C.cod f)) D Adj'.η (G (Adj.C.cod f))) D G f =
                      G' f D G' (Adj.ε (Adj.C.dom f)) D Adj'.η (G (Adj.C.dom f))"
          by auto
      qed
    qed
    interpret natural_isomorphism C D G G' τ.map
    proof
      fix a
      assume a: "Adj.C.ide a"
      show "Adj.D.iso (τ.map a)"
      proof
        show "Adj.D.inverse_arrows (τ.map a) (φ (G' a) (Adj'.ε a))"
        proof
          text‹
            The proof that the two composites are identities is a modest diagram chase.
            This is a good example of the inference rules for the category›,
            functor›, and natural_transformation› locales in action.
            Isabelle is able to use the single hypothesis that a› is an identity to
            implicitly fill in all the details that the various quantities are in fact arrows
            and that the indicated composites are all well-defined, as well as to apply
            associativity of composition.  In most cases, this is done by auto or simp without
            even mentioning any of the rules that are used.
$$\xymatrix{
        {G' a} \ar[dd]_{\eta'(G'a)} \ar[rr]^{\tau' a} \ar[dr]_{\eta(G'a)}
           && {G a} \ar[rr]^{\tau a} \ar[dr]_{\eta'(Ga)} && {G' a}                     \\
        & {GFG'a} \rrtwocell\omit{\omit(2)} \ar[ur]_{G(\epsilon' a)} \ar[dr]_{\eta'(GFG'a)}
           && {G'FGa} \drtwocell\omit{\omit(3)} \ar[ur]_{G'(\epsilon a)} &            \\
        {G'FG'a} \urtwocell\omit{\omit(1)} \ar[rr]_{G'F\eta(G'a)} \ar@/_8ex/[rrrr]_{G'FG'a}
           && {G'FGFG'a} \dtwocell\omit{\omit(4)} \ar[ru]_{G'FG(\epsilon' a)} \ar[rr]_{G'(\epsilon(FG'a))}
           && {G'FG'a} \ar[uu]_{G'(\epsilon' a)}                                       \\
           &&&&
}$$
›
          show "Adj.D.ide (τ.map a D φ (G' a) (Adj'.ε a))"
          proof -
            have "τ.map a D φ (G' a) (Adj'.ε a) = G' a"
            proof -
              have "τ.map a D φ (G' a) (Adj'.ε a) =
                    G' (Adj.ε a) D (Adj'.η (G a) D G (Adj'.ε a)) D Adj.η (G' a)"
                using a τ.map_simp_ide Adj.φ_in_terms_of_η Adj'.φ_in_terms_of_η
                      Adj'.ε.preserves_hom [of a a a] Adj.C.ide_in_hom Adj.D.comp_assoc
                      Adj.ε_def Adj.η_def
                by simp
              also have "... = G' (Adj.ε a) D (G' (F (G (Adj'.ε a))) D Adj'.η (G (F (G' a)))) D
                               Adj.η (G' a)"
                using a Adj'.η.naturality [of "G (Adj'.ε a)"] by auto
              also have "... = (G' (Adj.ε a) D G' (F (G (Adj'.ε a)))) D G' (F (Adj.η (G' a))) D
                               Adj'.η (G' a)"
                using a Adj'.η.naturality [of "Adj.η (G' a)"] Adj.D.comp_assoc by auto
              also have
                  "... = G' (Adj'.ε a) D (G' (Adj.ε (F (G' a))) D G' (F (Adj.η (G' a)))) D
                         Adj'.η (G' a)"
              proof -
                have
                   "G' (Adj.ε a) D G' (F (G (Adj'.ε a))) = G' (Adj'.ε a) D G' (Adj.ε (F (G' a)))"
                proof -
                  have "G' (Adj.ε a C F (G (Adj'.ε a))) = G' (Adj'.ε a C Adj.ε (F (G' a)))"
                    using a Adj.ε.naturality [of "Adj'.ε a"] by auto
                  thus ?thesis using a by force
                qed
                thus ?thesis using Adj.D.comp_assoc by auto
              qed
              also have "... = G' (Adj'.ε a) D Adj'.η (G' a)"
              proof -
                have "G' (Adj.ε (F (G' a))) D G' (F (Adj.η (G' a))) = G' (F (G' a))"
                proof -
                  have
                      "G' (Adj.ε (F (G' a))) D G' (F (Adj.η (G' a))) = G' (Adj.εFoFη.map (G' a))"
                    using a Adj.εFoFη.map_simp_1 by auto
                  moreover have "Adj.εFoFη.map (G' a) = F (G' a)"
                    using a by (simp add: Adj.ηε.triangle_F)
                  ultimately show ?thesis by auto
                qed
                thus ?thesis
                  using a Adj.D.comp_cod_arr [of "Adj'.η (G' a)"] by auto
              qed
              also have "... = G' a"
                using a Adj'.ηε.triangle_G Adj'.GεoηG.map_simp_1 [of a] by auto
              finally show ?thesis by auto
            qed
            thus ?thesis using a by simp
          qed
          show "Adj.D.ide (φ (G' a) (Adj'.ε a) D τ.map a)"
          proof -
            have "φ (G' a) (Adj'.ε a) D τ.map a = G a"
            proof -
              have "φ (G' a) (Adj'.ε a) D τ.map a =
                    G (Adj'.ε a) D (Adj.η (G' a) D G' (Adj.ε a)) D Adj'.η (G a)"
                using a τ.map_simp_ide Adj.φ_in_terms_of_η Adj'.ε.preserves_hom [of a a a]
                      Adj.C.ide_in_hom Adj.D.comp_assoc Adj.η_def
                by auto
              also have
                "... = G (Adj'.ε a) D (G (F (G' (Adj.ε a))) D Adj.η (G' (F (G a)))) D
                       Adj'.η (G a)"
                using a Adj.η.naturality [of "G' (Adj.ε a)"] by auto
              also have
                "... = (G (Adj'.ε a) D G (F (G' (Adj.ε a)))) D G (F (Adj'.η (G a))) D
                       Adj.η (G a)"
                using a Adj.η.naturality [of "Adj'.η (G a)"] Adj.D.comp_assoc by auto
              also have
                "... = G (Adj.ε a) D (G (Adj'.ε (F (G a))) D G (F (Adj'.η (G a)))) D
                       Adj.η (G a)"
              proof -
                have "G (Adj'.ε a) D G (F (G' (Adj.ε a))) = G (Adj.ε a) D G (Adj'.ε (F (G a)))"
                proof -
                  have "G (Adj'.ε a C F (G' (Adj.ε a))) = G (Adj.ε a C Adj'.ε (F (G a)))"
                    using a Adj'.ε.naturality [of "Adj.ε a"] by auto
                  thus ?thesis using a by force
                qed
                thus ?thesis using Adj.D.comp_assoc by auto
              qed
              also have "... = G (Adj.ε a) D Adj.η (G a)"
              proof -
                have "G (Adj'.ε (F (G a))) D G (F (Adj'.η (G a))) = G (F (G a))"
                proof -
                  have
                    "G (Adj'.ε (F (G a))) D G (F (Adj'.η (G a))) = G (Adj'.εFoFη.map (G a))"
                    using a Adj'.εFoFη.map_simp_1 [of "G a"] by auto
                  moreover have "Adj'.εFoFη.map (G a) = F (G a)"
                    using a by (simp add: Adj'.ηε.triangle_F)
                  ultimately show ?thesis by auto
                qed
                thus ?thesis
                  using a Adj.D.comp_cod_arr by auto
              qed
              also have "... = G a"
                using a Adj.ηε.triangle_G Adj.GεoηG.map_simp_1 [of a] by auto
              finally show ?thesis by auto
            qed
            thus ?thesis using a by auto
          qed
        qed
      qed
    qed
    have "natural_isomorphism C D G G' τ.map" ..
    thus "naturally_isomorphic C D G G'"
      using naturally_isomorphic_def by blast
  qed

end

Theory Limit

(*  Title:       Limit
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter Limit

theory Limit
imports FreeCategory DiscreteCategory Adjunction
begin

  text‹
    This theory defines the notion of limit in terms of diagrams and cones and relates
    it to the concept of a representation of a functor.  The diagonal functor associated
    with a diagram shape @{term J} is defined and it is shown that a right adjoint to
    the diagonal functor gives limits of shape @{term J} and that a category has limits
    of shape @{term J} if and only if the diagonal functor is a left adjoint functor.
    Products and equalizers are defined as special cases of limits, and it is shown
    that a category with equalizers has limits of shape @{term J} if it has products
    indexed by the sets of objects and arrows of @{term J}.
    The existence of limits in a set category is investigated, and it is shown that
    every set category has equalizers and that a set category @{term S} has @{term I}-indexed
    products if and only if the universe of @{term S} ``admits @{term I}-indexed tupling.''
    The existence of limits in functor categories is also developed, showing that
    limits in functor categories are ``determined pointwise'' and that a functor category
    @{term "[A, B]"} has limits of shape @{term J} if @{term B} does.
    Finally, it is shown that the Yoneda functor preserves limits.

    This theory concerns itself only with limits; I have made no attempt to consider colimits.
    Although it would be possible to rework the entire development in dual form,
    it is possible that there is a more efficient way to dualize at least parts of it without
    repeating all the work.  This is something that deserves further thought.
›

  section "Representations of Functors"

  text‹
    A representation of a contravariant functor F: Cop → S›, where @{term S}
    is a replete set category that is the target of a hom-functor for @{term C}, consists of
    an object @{term a} of @{term C} and a natural isomorphism @{term "Φ: Y a  F"},
    where Y: C → [Cop, S]› is the Yoneda functor.
›

  locale representation_of_functor =
    C: category C +
    Cop: dual_category C +
    S: replete_set_category S +
    F: "functor" Cop.comp S F +
    Hom: hom_functor C S φ +
    Ya: yoneda_functor_fixed_object C S φ a +
    natural_isomorphism Cop.comp S ‹Ya.Y a F Φ
  for C :: "'c comp"      (infixr "" 55)
  and S :: "'s comp"      (infixr "S" 55)
  and φ :: "'c * 'c  'c  's"
  and F :: "'c  's"
  and a :: 'c
  and Φ :: "'c  's"
  begin

     abbreviation Y where "Y  Ya.Y"
     abbreviation ψ where "ψ  Hom.ψ"

  end

  text‹
    Two representations of the same functor are uniquely isomorphic.
›

  locale two_representations_one_functor =
    C: category C +
    Cop: dual_category C +
    S: replete_set_category S +
    F: set_valued_functor Cop.comp S F +
    yoneda_functor C S φ +
    Ya: yoneda_functor_fixed_object C S φ a +
    Ya': yoneda_functor_fixed_object C S φ a' +
    Φ: representation_of_functor C S φ F a Φ +
    Φ': representation_of_functor C S φ F a' Φ'
  for C :: "'c comp"      (infixr "" 55)
  and S :: "'s comp"      (infixr "S" 55)
  and F :: "'c  's"
  and φ :: "'c * 'c  'c  's"
  and a :: 'c
  and Φ :: "'c  's"
  and a' :: 'c
  and Φ' :: "'c  's"
  begin

    interpretation Ψ: inverse_transformation Cop.comp S ‹Y a F Φ ..
    interpretation Ψ': inverse_transformation Cop.comp S ‹Y a' F Φ' ..
    interpretation ΦΨ': vertical_composite Cop.comp S ‹Y a F ‹Y a' Φ Ψ'.map ..
    interpretation Φ'Ψ: vertical_composite Cop.comp S ‹Y a' F ‹Y a Φ' Ψ.map ..

    lemma are_uniquely_isomorphic:
      shows "∃!φ. «φ : a  a'»  C.iso φ  map φ = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
    proof -
      have "natural_isomorphism Cop.comp S (Y a) F Φ" ..
      moreover have "natural_isomorphism Cop.comp S F (Y a') Ψ'.map" ..
      ultimately have 1: "natural_isomorphism Cop.comp S (Y a) (Y a') ΦΨ'.map"
        using NaturalTransformation.natural_isomorphisms_compose by blast
      interpret ΦΨ': natural_isomorphism Cop.comp S ‹Y a ‹Y a' ΦΨ'.map
        using 1 by auto

      have "natural_isomorphism Cop.comp S (Y a') F Φ'" ..
      moreover have "natural_isomorphism Cop.comp S F (Y a) Ψ.map" ..
      ultimately have 2: "natural_isomorphism Cop.comp S (Y a') (Y a) Φ'Ψ.map"
        using NaturalTransformation.natural_isomorphisms_compose by blast
      interpret Φ'Ψ: natural_isomorphism Cop.comp S ‹Y a' ‹Y a Φ'Ψ.map
        using 2 by auto

      interpret ΦΨ'_Φ'Ψ: inverse_transformations Cop.comp S ‹Y a ‹Y a' ΦΨ'.map Φ'Ψ.map
      proof
        fix x
        assume X: "Cop.ide x"
        show "S.inverse_arrows (ΦΨ'.map x) (Φ'Ψ.map x)"
        proof
          have 1: "S.arr (ΦΨ'.map x)  ΦΨ'.map x = Ψ'.map x S Φ x"
            using X ΦΨ'.preserves_reflects_arr [of x]
            by (simp add: ΦΨ'.map_simp_2)
          have 2: "S.arr (Φ'Ψ.map x)  Φ'Ψ.map x = Ψ.map x S Φ' x"
            using X Φ'Ψ.preserves_reflects_arr [of x]
            by (simp add: Φ'Ψ.map_simp_1)
          show "S.ide (ΦΨ'.map x S Φ'Ψ.map x)"
            using 1 2 X Ψ.is_natural_2 Ψ'.inverts_components Ψ.inverts_components
            by (metis S.inverse_arrows_def S.inverse_arrows_compose)
          show "S.ide (Φ'Ψ.map x S ΦΨ'.map x)"
            using 1 2 X Ψ'.inverts_components Ψ.inverts_components
            by (metis S.inverse_arrows_def S.inverse_arrows_compose)
        qed
      qed

      have "Cop_S.inverse_arrows (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)
                                 (Cop_S.MkArr (Y a') (Y a) Φ'Ψ.map)"
      proof -
        have Ya: "functor Cop.comp S (Y a)" ..
        have Ya': "functor Cop.comp S (Y a')" ..
        have ΦΨ': "natural_transformation Cop.comp S (Y a) (Y a') ΦΨ'.map" ..
        have Φ'Ψ: "natural_transformation Cop.comp S (Y a') (Y a) Φ'Ψ.map" ..
        show ?thesis
        proof (intro Cop_S.inverse_arrowsI)
          have 0: "inverse_transformations Cop.comp S (Y a) (Y a') ΦΨ'.map Φ'Ψ.map" ..
          have 1: "Cop_S.antipar (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)
                                 (Cop_S.MkArr (Y a') (Y a) Φ'Ψ.map)"
            using Ya Ya' ΦΨ' Φ'Ψ Cop_S.dom_char Cop_S.cod_char Cop_S.seqI
                  Cop_S.arr_MkArr Cop_S.cod_MkArr Cop_S.dom_MkArr
            by presburger
          show "Cop_S.ide (Cop_S.comp (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)
                                      (Cop_S.MkArr (Y a') (Y a) Φ'Ψ.map))"
            using 0 1 NaturalTransformation.inverse_transformations_inverse(2) Cop_S.comp_MkArr
            by (metis Cop_S.cod_MkArr Cop_S.ide_char' Cop_S.seqE)
          show "Cop_S.ide (Cop_S.comp (Cop_S.MkArr (Y a') (Y a) Φ'Ψ.map)
                                      (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map))"
            using 0 1 NaturalTransformation.inverse_transformations_inverse(1) Cop_S.comp_MkArr
            by (metis Cop_S.cod_MkArr Cop_S.ide_char' Cop_S.seqE)
        qed
      qed
      hence 3: "Cop_S.iso (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)" using Cop_S.isoI by blast
      hence "Cop_S.arr (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map)" using Cop_S.iso_is_arr by blast
      hence "Cop_S.in_hom (Cop_S.MkArr (Y a) (Y a') ΦΨ'.map) (map a) (map a')"
        using Ya.ide_a Ya'.ide_a Cop_S.dom_char Cop_S.cod_char by auto
      hence "f. «f : a  a'»  map f = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
        using Ya.ide_a Ya'.ide_a is_full Y_def Cop_S.iso_is_arr full_functor.is_full
        by auto     
      from this obtain φ
        where φ: "«φ : a  a'»  map φ = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
        by blast
      from φ have "C.iso φ"
        using 3 reflects_iso [of φ a a'] by simp
      hence EX: "φ. «φ : a  a'»  C.iso φ  map φ = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
        using φ by blast
      have
        UN: "φ'. «φ' : a  a'»  map φ' = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map  φ' = φ"
      proof -
        fix φ'
        assume φ': "«φ' : a  a'»  map φ' = Cop_S.MkArr (Y a) (Y a') ΦΨ'.map"
        have "C.par φ φ'  map φ = map φ'" using φ φ' by auto
        thus "φ' = φ" using is_faithful by fast
      qed
      from EX UN show ?thesis by auto
    qed

  end

  section "Diagrams and Cones"

  text‹
    A \emph{diagram} in a category @{term C} is a functor D: J → C›.
    We refer to the category @{term J} as the diagram \emph{shape}.
    Note that in the usual expositions of category theory that use set theory
    as their foundations, the shape @{term J} of a diagram is required to be
    a ``small'' category, where smallness means that the collection of objects
    of @{term J}, as well as each of the ``homs,'' is a set.
    However, in HOL there is no class of all sets, so it is not meaningful
    to speak of @{term J} as ``small'' in any kind of absolute sense.
    There is likely a meaningful notion of smallness of @{term J}
    \emph{relative to} @{term C} (the result below that states that a set
    category has @{term I}-indexed products if and only if its universe
    ``admits @{term I}-indexed tuples'' is suggestive of how this might
    be defined), but I haven't fully explored this idea at present.
›

  locale diagram =
    C: category C +
    J: category J +
    "functor" J C D
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'j  'c"
  begin

    notation J.in_hom ("«_ : _ J _»")

  end
 
  lemma comp_diagram_functor:
  assumes "diagram J C D" and "functor J' J F"
  shows "diagram J' C (D o F)"
    by (meson assms(1) assms(2) diagram_def functor.axioms(1) functor_comp)
    
  text‹
    A \emph{cone} over a diagram D: J → C› is a natural transformation
    from a constant functor to @{term D}.  The value of the constant functor is
    the \emph{apex} of the cone.
›

  locale cone =
    C: category C +
    J: category J +
    D: diagram J C D +
    A: constant_functor J C a +
    natural_transformation J C A.map D χ
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'j  'c"
  and a :: 'c
  and χ :: "'j  'c"
  begin

    lemma ide_apex:
    shows "C.ide a"
      using A.value_is_ide by auto

    lemma component_in_hom:
    assumes "J.arr j"
    shows "«χ j : a  D (J.cod j)»"
      using assms by auto

  end

  text‹
    A cone over diagram @{term D} is transformed into a cone over diagram @{term "D o F"}
    by pre-composing with @{term F}.
›

  lemma comp_cone_functor:
  assumes "cone J C D a χ" and "functor J' J F"
  shows "cone J' C (D o F) a (χ o F)"
  proof -
    interpret χ: cone J C D a χ using assms(1) by auto
    interpret F: "functor" J' J F using assms(2) by auto
    interpret A': constant_functor J' C a
      apply unfold_locales using χ.A.value_is_ide by auto
    have 1: "χ.A.map o F = A'.map"
      using χ.A.map_def A'.map_def χ.J.not_arr_null by auto
    interpret χ': natural_transformation J' C A'.map D o F χ o F
      using 1 horizontal_composite F.natural_transformation_axioms
            χ.natural_transformation_axioms
      by fastforce
    show "cone J' C (D o F) a (χ o F)" ..
  qed

  text‹
    A cone over diagram @{term D} can be transformed into a cone over a diagram @{term D'}
    by post-composing with a natural transformation from @{term D} to @{term D'}.
›

  lemma vcomp_transformation_cone:
  assumes "cone J C D a χ"
  and "natural_transformation J C D D' τ"
  shows "cone J C D' a (vertical_composite.map J C χ τ)"
  proof -
    interpret χ: cone J C D a χ using assms(1) by auto
    interpret τ: natural_transformation J C D D' τ using assms(2) by auto
    interpret τoχ: vertical_composite J C χ.A.map D D' χ τ ..
    interpret τoχ: cone J C D' a τoχ.map ..
    show ?thesis ..
  qed

  context "functor"
  begin

    lemma preserves_diagrams:
    fixes J :: "'j comp"
    assumes "diagram J A D"
    shows "diagram J B (F o D)"
    proof -
      interpret D: diagram J A D using assms by auto
      interpret FoD: composite_functor J A B D F ..
      show "diagram J B (F o D)" ..
    qed

    lemma preserves_cones:
    fixes J :: "'j comp"
    assumes "cone J A D a χ"
    shows "cone J B (F o D) (F a) (F o χ)"
    proof -
      interpret χ: cone J A D a χ using assms by auto
      interpret Fa: constant_functor J B F a
        apply unfold_locales using χ.ide_apex by auto
      have 1: "F o χ.A.map = Fa.map"
      proof
        fix f
        show "(F  χ.A.map) f = Fa.map f"
          using is_extensional Fa.is_extensional χ.A.is_extensional
          by (cases "χ.J.arr f", simp_all)
      qed
      interpret χ': natural_transformation J B Fa.map F o D F o χ
        using 1 horizontal_composite χ.natural_transformation_axioms
              natural_transformation_axioms
        by fastforce
      show "cone J B (F o D) (F a) (F o χ)" ..
    qed

  end

  context diagram
  begin

    abbreviation cone
    where "cone a χ  Limit.cone J C D a χ"

    abbreviation cones :: "'c  ('j  'c) set"
    where "cones a  { χ. cone a χ }"

    text‹
      An arrow @{term "f  C.hom a' a"} induces by composition a transformation from
      cones with apex @{term a} to cones with apex @{term a'}.  This transformation
      is functorial in @{term f}.
›

    abbreviation cones_map :: "'c  ('j  'c)  ('j  'c)"
    where "cones_map f  (λχ  cones (C.cod f). λj. if J.arr j then χ j  f else C.null)"

    lemma cones_map_mapsto:
    assumes "C.arr f"
    shows "cones_map f 
             extensional (cones (C.cod f))  (cones (C.cod f)  cones (C.dom f))"
    proof
      show "cones_map f  extensional (cones (C.cod f))" by blast
      show "cones_map f  cones (C.cod f)  cones (C.dom f)"
      proof
        fix χ
        assume "χ  cones (C.cod f)"
        hence χ: "cone (C.cod f) χ" by auto
        interpret χ: cone J C D ‹C.cod f χ using χ by auto
        interpret B: constant_functor J C ‹C.dom f
          apply unfold_locales using assms by auto
        have "cone (C.dom f) (λj. if J.arr j then χ j  f else C.null)"
          using assms B.value_is_ide χ.is_natural_1 χ.is_natural_2
          apply (unfold_locales, auto)
          using χ.is_natural_1
           apply (metis C.comp_assoc)
          using χ.is_natural_2 C.comp_arr_dom
          by (metis J.arr_cod_iff_arr J.cod_cod C.comp_assoc)
        thus "(λj. if J.arr j then χ j  f else C.null)  cones (C.dom f)" by auto
      qed
    qed

    lemma cones_map_ide:
    assumes "χ  cones a"
    shows "cones_map a χ = χ"
    proof -
      interpret χ: cone J C D a χ using assms by auto
      show ?thesis
      proof
        fix j
        show "cones_map a χ j = χ j"
          using assms χ.A.value_is_ide χ.preserves_hom C.comp_arr_dom χ.is_extensional
          by (cases "J.arr j", auto)
      qed
    qed

    lemma cones_map_comp:
    assumes "C.seq f g"
    shows "cones_map (f  g) = restrict (cones_map g o cones_map f) (cones (C.cod f))"
    proof (intro restr_eqI)
      show "cones (C.cod (f  g)) = cones (C.cod f)" using assms by simp
      show "χ. χ  cones (C.cod (f  g)) 
                  (λj. if J.arr j then χ j  f  g else C.null) = (cones_map g o cones_map f) χ"
      proof -
        fix χ
        assume χ: "χ  cones (C.cod (f  g))"
        show "(λj. if J.arr j then χ j  f  g else C.null) = (cones_map g o cones_map f) χ"
        proof -
          have "((cones_map g) o (cones_map f)) χ = cones_map g (cones_map f χ)"
            by force
          also have "... = (λj. if J.arr j then
                              (λj. if J.arr j then χ j  f else C.null) j  g else C.null)"
          proof
            fix j
            have "cone (C.dom f) (cones_map f χ)"
              using assms χ cones_map_mapsto by (elim C.seqE, force)
            thus "cones_map g (cones_map f χ) j =
                  (if J.arr j then C (if J.arr j then χ j  f else C.null) g else C.null)"
              using χ assms by auto
          qed
          also have "... = (λj. if J.arr j then χ j  f  g else C.null)"
          proof -
            have "j. J.arr j  (χ j  f)  g = χ j  f  g"
            proof -
              interpret χ: cone J C D ‹C.cod f χ using assms χ by auto
              fix j
              assume j: "J.arr j"
              show "(χ j  f)  g = χ j  f  g"
                using assms C.comp_assoc by simp
            qed
            thus ?thesis by auto
          qed
          finally show ?thesis by auto
        qed
      qed
    qed

  end

  text‹
    Changing the apex of a cone by pre-composing with an arrow @{term f} commutes
    with changing the diagram of a cone by post-composing with a natural transformation.
›

  lemma cones_map_vcomp:
  assumes "diagram J C D" and "diagram J C D'"
  and "natural_transformation J C D D' τ"
  and "cone J C D a χ"
  and f: "partial_magma.in_hom C f a' a"
  shows "diagram.cones_map J C D' f (vertical_composite.map J C χ τ)
           = vertical_composite.map J C (diagram.cones_map J C D f χ) τ"
  proof -
    interpret D: diagram J C D using assms(1) by auto
    interpret D': diagram J C D' using assms(2) by auto
    interpret τ: natural_transformation J C D D' τ using assms(3) by auto
    interpret χ: cone J C D a χ using assms(4) by auto
    interpret τoχ: vertical_composite J C χ.A.map D D' χ τ ..
    interpret τoχ: cone J C D' a τoχ.map ..
    interpret χf: cone J C D a' ‹D.cones_map f χ
      using f χ.cone_axioms D.cones_map_mapsto by blast
    interpret τoχf: vertical_composite J C χf.A.map D D' ‹D.cones_map f χ τ ..
    interpret τoχ_f: cone J C D' a' ‹D'.cones_map f τoχ.map›
      using f τoχ.cone_axioms D'.cones_map_mapsto [of f] by blast
    write C (infixr "" 55)
    show "D'.cones_map f τoχ.map = τoχf.map"
    proof (intro NaturalTransformation.eqI)
      show "natural_transformation J C χf.A.map D' (D'.cones_map f τoχ.map)" ..
      show "natural_transformation J C χf.A.map D' τoχf.map" ..
      show "j. D.J.ide j  D'.cones_map f τoχ.map j = τoχf.map j"
      proof -
        fix j
        assume j: "D.J.ide j"
        have "D'.cones_map f τoχ.map j = τoχ.map j  f"
          using f τoχ.cone_axioms τoχ.map_simp_2 τoχ.is_extensional by auto
        also have "... = (τ j  χ (D.J.dom j))  f"
          using j τoχ.map_simp_2 by simp
        also have "... = τ j  χ (D.J.dom j)  f"
          using D.C.comp_assoc by simp
        also have "... = τoχf.map j"
          using j f χ.cone_axioms τoχf.map_simp_2 by auto
        finally show "D'.cones_map f τoχ.map j = τoχf.map j" by auto
      qed
    qed
  qed

  text‹
    Given a diagram @{term D}, we can construct a contravariant set-valued functor,
    which takes each object @{term a} of @{term C} to the set of cones over @{term D}
    with apex @{term a}, and takes each arrow @{term f} of @{term C} to the function
    on cones over @{term D} induced by pre-composition with @{term f}.
    For this, we need to introduce a set category @{term S} whose universe is large
    enough to contain all the cones over @{term D}, and we need to have an explicit
    correspondence between cones and elements of the universe of @{term S}.
    A replete set category @{term S} equipped with an injective mapping
    @{term_type "ι :: ('j => 'c) => 's"} serves this purpose.
›
  locale cones_functor =
    C: category C +
    Cop: dual_category C +
    J: category J +
    D: diagram J C D +
    S: replete_concrete_set_category S UNIV ι
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'j  'c"
  and S :: "'s comp"      (infixr "S" 55)
  and ι :: "('j  'c)  's"
  begin

    notation S.in_hom     ("«_ : _ S _»")

    abbreviation 𝗈 where "𝗈  S.𝗈"

    definition map :: "'c  's"
    where "map = (λf. if C.arr f then
                        S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom f))
                                (ι o D.cones_map f o 𝗈)
                      else S.null)"

    lemma map_simp [simp]:
    assumes "C.arr f"
    shows "map f = S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom f))
                           (ι o D.cones_map f o 𝗈)"
      using assms map_def by auto

    lemma arr_map:
    assumes "C.arr f"
    shows "S.arr (map f)"
    proof -
      have "ι o D.cones_map f o 𝗈  ι ` D.cones (C.cod f)  ι ` D.cones (C.dom f)"
        using assms D.cones_map_mapsto by force
      thus ?thesis using assms S.ι_mapsto S.arr_mkArr by auto
    qed

    lemma map_ide:
    assumes "C.ide a"
    shows "map a = S.mkIde (ι ` D.cones a)"
    proof -
      have "map a = S.mkArr (ι ` D.cones a) (ι ` D.cones a) (ι o D.cones_map a o 𝗈)"
        using assms map_simp by force
      also have "... = S.mkArr (ι ` D.cones a) (ι ` D.cones a) (λx. x)"
        using S.ι_mapsto D.cones_map_ide S.arr_mkArr by force
      also have "... = S.mkIde (ι ` D.cones a)"
        using assms S.mkIde_as_mkArr S.ι_mapsto by blast
      finally show ?thesis by auto
    qed

    lemma map_preserves_dom:
    assumes "Cop.arr f"
    shows "map (Cop.dom f) = S.dom (map f)"
      using assms arr_map map_ide by auto

    lemma map_preserves_cod:
    assumes "Cop.arr f"
    shows "map (Cop.cod f) = S.cod (map f)"
      using assms arr_map map_ide by auto

    lemma map_preserves_comp:
    assumes "Cop.seq g f"
    shows "map (g op f) = map g S map f"
    proof -
      have "map (g op f) = S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom g))
                                   ((ι o D.cones_map g o 𝗈) o (ι o D.cones_map f o 𝗈))"
      proof -
        have 1: "S.arr (map (g op f))"
          using assms arr_map [of "C f g"] by simp
        have "map (g op f) = S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom g))
                                     (ι o D.cones_map (C f g) o 𝗈)"
          using assms map_simp [of "C f g"] by simp
        also have "... = S.mkArr (ι ` D.cones (C.cod f)) (ι ` D.cones (C.dom g))
                                 ((ι o D.cones_map g o 𝗈) o (ι o D.cones_map f o 𝗈))"
          using assms 1 calculation D.cones_map_mapsto D.cones_map_comp by auto
        finally show ?thesis by blast
      qed
      also have "... = map g S map f"
        using assms arr_map [of f] arr_map [of g] map_simp S.comp_mkArr by auto
      finally show ?thesis by auto
    qed

    lemma is_functor:
    shows "functor Cop.comp S map"
      apply (unfold_locales)
      using map_def arr_map map_preserves_dom map_preserves_cod map_preserves_comp
      by auto
    
  end

  sublocale cones_functor  "functor" Cop.comp S map using is_functor by auto
  sublocale cones_functor  set_valued_functor Cop.comp S map ..

  section Limits

  subsection "Limit Cones"

  text‹
    A \emph{limit cone} for a diagram @{term D} is a cone @{term χ} over @{term D}
    with the universal property that any other cone @{term χ'} over the diagram @{term D}
    factors uniquely through @{term χ}.
›

  locale limit_cone =
    C: category C +
    J: category J +
    D: diagram J C D +
    cone J C D a χ
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'j  'c"
  and a :: 'c
  and χ :: "'j  'c" +
  assumes is_universal: "cone J C D a' χ'  ∃!f. «f : a'  a»  D.cones_map f χ = χ'"
  begin

    definition induced_arrow :: "'c  ('j  'c)  'c"
    where "induced_arrow a' χ' = (THE f. «f : a'  a»  D.cones_map f χ = χ')"

    lemma induced_arrowI:
    assumes χ': "χ'  D.cones a'"
    shows "«induced_arrow a' χ' : a'  a»"
    and "D.cones_map (induced_arrow a' χ') χ = χ'"
    proof -
      have "∃!f. «f : a'  a»  D.cones_map f χ = χ'"
        using assms χ' is_universal by simp
      hence 1: "«induced_arrow a' χ' : a'  a»  D.cones_map (induced_arrow a' χ') χ = χ'"
        using theI' [of "λf. «f : a'  a»  D.cones_map f χ = χ'"] induced_arrow_def
        by presburger
      show "«induced_arrow a' χ' : a'  a»" using 1 by simp
      show "D.cones_map (induced_arrow a' χ') χ = χ'" using 1 by simp
    qed

    lemma cones_map_induced_arrow:
    shows "induced_arrow a'  D.cones a'  C.hom a' a"
    and "χ'. χ'  D.cones a'  D.cones_map (induced_arrow a' χ') χ = χ'"
      using induced_arrowI by auto

    lemma induced_arrow_cones_map:
    assumes "C.ide a'"
    shows "(λf. D.cones_map f χ)  C.hom a' a  D.cones a'"
    and "f. «f : a'  a»  induced_arrow a' (D.cones_map f χ) = f"
    proof -
      have a': "C.ide a'" using assms by (simp add: cone.ide_apex)
      have cone_χ: "cone J C D a χ" ..
      show "(λf. D.cones_map f χ)  C.hom a' a  D.cones a'"
        using cone_χ D.cones_map_mapsto by blast
      fix f
      assume f: "«f : a'  a»"
      show "induced_arrow a' (D.cones_map f χ) = f"
      proof -
        have "D.cones_map f χ  D.cones a'"
          using f cone_χ D.cones_map_mapsto by blast
        hence "∃!f'. «f' : a'  a»  D.cones_map f' χ = D.cones_map f χ"
          using assms is_universal by auto
        thus ?thesis
          using f induced_arrow_def
                the1_equality [of "λf'. «f' : a'  a»  D.cones_map f' χ = D.cones_map f χ"]
          by presburger
      qed
    qed

    text‹
      For a limit cone @{term χ} with apex @{term a}, for each object @{term a'} the
      hom-set @{term "C.hom a' a"} is in bijective correspondence with the set of cones
      with apex @{term a'}.
›

    lemma bij_betw_hom_and_cones:
    assumes "C.ide a'"
    shows "bij_betw (λf. D.cones_map f χ) (C.hom a' a) (D.cones a')"
    proof (intro bij_betwI)
      show "(λf. D.cones_map f χ)  C.hom a' a  D.cones a'"
        using assms induced_arrow_cones_map by blast
      show "induced_arrow a'  D.cones a'  C.hom a' a"
        using assms cones_map_induced_arrow by blast
      show "f. f  C.hom a' a  induced_arrow a' (D.cones_map f χ) = f"
        using assms induced_arrow_cones_map by blast
      show "χ'. χ'  D.cones a'  D.cones_map (induced_arrow a' χ') χ = χ'"
        using assms cones_map_induced_arrow by blast
    qed

    lemma induced_arrow_eqI:
    assumes "D.cone a' χ'" and "«f : a'  a»" and "D.cones_map f χ = χ'"
    shows "induced_arrow a' χ' = f"
      using assms is_universal induced_arrow_def
            the1_equality [of "λf. f  C.hom a' a  D.cones_map f χ = χ'" f]
      by simp

    lemma induced_arrow_self:
    shows "induced_arrow a χ = a"
    proof -
      have "«a : a  a»  D.cones_map a χ = χ"
        using ide_apex cone_axioms D.cones_map_ide by force
      thus ?thesis using induced_arrow_eqI cone_axioms by auto
    qed

  end

  context diagram
  begin

    abbreviation limit_cone
    where "limit_cone a χ  Limit.limit_cone J C D a χ"

    text‹
      A diagram @{term D} has object @{term a} as a limit if @{term a} is the apex
      of some limit cone over @{term D}.
›

    abbreviation has_as_limit :: "'c  bool"
    where "has_as_limit a  (χ. limit_cone a χ)"

    abbreviation has_limit
    where "has_limit  (a χ. limit_cone a χ)"

    definition some_limit :: 'c
    where "some_limit = (SOME a. χ. limit_cone a χ)"

    definition some_limit_cone :: "'j  'c"
    where "some_limit_cone = (SOME χ. limit_cone some_limit χ)"

    lemma limit_cone_some_limit_cone:
    assumes has_limit
    shows "limit_cone some_limit some_limit_cone"
    proof -
      have "a. has_as_limit a" using assms by simp
      hence "has_as_limit some_limit"
        using some_limit_def someI_ex [of "λa. χ. limit_cone a χ"] by simp
      thus "limit_cone some_limit some_limit_cone"
        using assms some_limit_cone_def someI_ex [of "λχ. limit_cone some_limit χ"]
        by simp
    qed

    lemma ex_limitE:
    assumes "a. has_as_limit a"
    obtains a χ where "limit_cone a χ"
      using assms someI_ex by blast

  end

  subsection "Limits by Representation"

  text‹
    A limit for a diagram D can also be given by a representation (a, Φ)›
    of the cones functor.
›

  locale representation_of_cones_functor =
    C: category C +
    Cop: dual_category C +
    J: category J +
    D: diagram J C D +
    S: replete_concrete_set_category S UNIV ι +
    Cones: cones_functor J C D S ι +
    Hom: hom_functor C S φ +
    representation_of_functor C S φ Cones.map a Φ
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'j  'c"
  and S :: "'s comp"      (infixr "S" 55)
  and φ :: "'c * 'c  'c  's"
  and ι :: "('j  'c)  's"
  and a :: 'c
  and Φ :: "'c  's"

  subsection "Putting it all Together"

  text‹
    A ``limit situation'' combines and connects the ways of presenting a limit.
›

  locale limit_situation =
    C: category C +
    Cop: dual_category C +
    J: category J +
    D: diagram J C D +
    S: replete_concrete_set_category S UNIV ι +
    Cones: cones_functor J C D S ι +
    Hom: hom_functor C S φ +
    Φ: representation_of_functor C S φ Cones.map a Φ +
    χ: limit_cone J C D a χ
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'j  'c"
  and S :: "'s comp"      (infixr "S" 55)
  and φ :: "'c * 'c  'c  's"
  and ι :: "('j  'c)  's"
  and a :: 'c
  and Φ :: "'c  's"
  and χ :: "'j  'c" +
  assumes χ_in_terms_of_Φ: "χ = S.𝗈 (S.Fun (Φ a) (φ (a, a) a))"
  and Φ_in_terms_of_χ:
     "Cop.ide a'  Φ a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a')
                                    (λx. ι (D.cones_map (Hom.ψ (a', a) x) χ))"

  text (in limit_situation) ‹
    The assumption @{prop χ_in_terms_of_Φ} states that the universal cone @{term χ} is obtained
    by applying the function @{term "S.Fun (Φ a)"} to the identity @{term a} of
    @{term[source=true] C} (after taking into account the necessary coercions).
›

  text (in limit_situation) ‹
    The assumption @{prop Φ_in_terms_of_χ} states that the component of @{term Φ} at @{term a'}
    is the arrow of @{term[source=true] S} corresponding to the function that takes an arrow
    @{term "f  C.hom a' a"} and produces the cone with vertex @{term a'} obtained
    by transforming the universal cone @{term χ} by @{term f}.
›

  subsection "Limit Cones Induce Limit Situations"

  text‹
    To obtain a limit situation from a limit cone, we need to introduce a set category
    that is large enough to contain the hom-sets of @{term C} as well as the cones
    over @{term D}.  We use the category of all @{typ "('c + ('j  'c))"}-sets for this.
›

  context limit_cone
  begin

    interpretation Cop: dual_category C ..
    interpretation CopxC: product_category Cop.comp C ..
    interpretation S: replete_setcat ‹undefined :: 'c + ('j  'c) .

    notation S.comp      (infixr "S" 55)

    interpretation Sr: replete_concrete_set_category S.comp UNIV ‹S.UP o Inr›
      apply unfold_locales
      using S.UP_mapsto
       apply auto[1]
      using S.inj_UP inj_Inr inj_compose
      by metis

    interpretation Cones: cones_functor J C D S.comp ‹S.UP o Inr› ..

    interpretation Hom: hom_functor C S.comp λ_. S.UP o Inl›
      apply (unfold_locales)
      using S.UP_mapsto
       apply auto[1]
      using S.inj_UP injD inj_onI inj_Inl inj_compose
      by (metis (no_types, lifting))

    interpretation Y: yoneda_functor C S.comp λ_. S.UP o Inl› ..
    interpretation Ya: yoneda_functor_fixed_object C S.comp λ_. S.UP o Inl› a
      apply (unfold_locales) using ide_apex by auto

    abbreviation inl :: "'c  'c + ('j  'c)" where "inl  Inl"
    abbreviation inr :: "('j  'c)  'c + ('j  'c)" where "inr  Inr"
    abbreviation ι where "ι  S.UP o inr"
    abbreviation 𝗈 where "𝗈  Cones.𝗈"
    abbreviation φ where "φ  λ_. S.UP o inl"
    abbreviation ψ where "ψ  Hom.ψ"
    abbreviation Y where "Y  Y.Y"

    lemma Ya_ide:
    assumes a': "C.ide a'"
    shows "Y a a' = S.mkIde (Hom.set (a', a))"
      using assms ide_apex Y.Y_simp Hom.map_ide by simp

    lemma Ya_arr:
    assumes g: "C.arr g"
    shows "Y a g = S.mkArr (Hom.set (C.cod g, a)) (Hom.set (C.dom g, a))
                           (φ (C.dom g, a) o Cop.comp g o ψ (C.cod g, a))"
      using ide_apex g Y.Y_ide_arr [of a g "C.dom g" "C.cod g"] by auto

    lemma cone_χ [simp]:
    shows "χ  D.cones a"
      using cone_axioms by simp
    
    text‹
      For each object @{term a'} of @{term[source=true] C} we have a function mapping
      @{term "C.hom a' a"} to the set of cones over @{term D} with apex @{term a'},
      which takes @{term "f  C.hom a' a"} to χf›, where χf› is the cone obtained by
      composing @{term χ} with @{term f} (after accounting for coercions to and from the
      universe of @{term S}).  The corresponding arrows of @{term S} are the
      components of a natural isomorphism from @{term "Y a"} to Cones›.
›

    definition Φo :: "'c  ('c + ('j  'c)) setcat.arr"
    where
      "Φo a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') (λx. ι (D.cones_map (ψ (a', a) x) χ))"

    lemma Φo_in_hom:
    assumes a': "C.ide a'"
    shows "«Φo a' : S.mkIde (Hom.set (a', a)) S S.mkIde (ι ` D.cones a')»"
    proof -
      have " «S.mkArr (Hom.set (a', a)) (ι ` D.cones a') (λx. ι (D.cones_map (ψ (a', a) x) χ)) :
                 S.mkIde (Hom.set (a', a)) S S.mkIde (ι ` D.cones a')»"
      proof -
        have "(λx. ι (D.cones_map (ψ (a', a) x) χ))  Hom.set (a', a)  ι ` D.cones a'"
        proof
          fix x
          assume x: "x  Hom.set (a', a)"
          hence "«ψ (a', a) x : a'  a»"
            using ide_apex a' Hom.ψ_mapsto by auto
          hence "D.cones_map (ψ (a', a) x) χ  D.cones a'"
            using ide_apex a' x D.cones_map_mapsto cone_χ by force
          thus (D.cones_map (ψ (a', a) x) χ)  ι ` D.cones a'" by simp
        qed
        moreover have "Hom.set (a', a)  S.Univ"
          using ide_apex a' Hom.set_subset_Univ by auto
        moreover have ` D.cones a'  S.Univ"
          using S.UP_mapsto by auto
        ultimately show ?thesis using S.mkArr_in_hom by simp
      qed
      thus ?thesis using Φo_def [of a'] by auto
    qed

    interpretation Φ: transformation_by_components Cop.comp S.comp ‹Y a Cones.map Φo
    proof
      fix a'
      assume A': "Cop.ide a'"
      show "«Φo a' : Y a a' S Cones.map a'»"
        using A' Ya_ide Φo_in_hom Cones.map_ide by auto
      next
      fix g
      assume g: "Cop.arr g"
      show "Φo (Cop.cod g) S Y a g = Cones.map g S Φo (Cop.dom g)"
      proof -
        let ?A = "Hom.set (C.cod g, a)"
        let ?B = "Hom.set (C.dom g, a)"
        let ?B' = ` D.cones (C.cod g)"
        let ?C = ` D.cones (C.dom g)"
        let ?F = (C.dom g, a) o Cop.comp g o ψ (C.cod g, a)"
        let ?F' = o D.cones_map g o 𝗈"
        let ?G = "λx. ι (D.cones_map (ψ (C.dom g, a) x) χ)"
        let ?G' = "λx. ι (D.cones_map (ψ (C.cod g, a) x) χ)"
        have "S.arr (Y a g)  Y a g = S.mkArr ?A ?B ?F"
          using ide_apex g Ya.preserves_arr Ya_arr by fastforce
        moreover have "S.arr (Φo (Cop.cod g))"
          using g Φo_in_hom [of "Cop.cod g"] by auto
        moreover have "Φo (Cop.cod g) = S.mkArr ?B ?C ?G"
          using g Φo_def [of "C.dom g"] by auto
        moreover have "S.seq (Φo (Cop.cod g)) (Y a g)"
          using ide_apex g Φo_in_hom [of "Cop.cod g"] by auto
        ultimately have 1: "S.seq (Φo (Cop.cod g)) (Y a g) 
                            Φo (Cop.cod g) S Y a g = S.mkArr ?A ?C (?G o ?F)"
          using S.comp_mkArr [of ?A ?B ?F ?C ?G] by argo

        have "Cones.map g = S.mkArr (ι ` D.cones (C.cod g)) (ι ` D.cones (C.dom g)) ?F'"
          using g Cones.map_simp by fastforce
        moreover have "Φo (Cop.dom g) = S.mkArr ?A ?B' ?G'"
          using g Φo_def by fastforce
        moreover have "S.seq (Cones.map g) (Φo (Cop.dom g))"
          using g Cones.preserves_hom [of g "C.cod g" "C.dom g"] Φo_in_hom [of "Cop.dom g"]
          by force
        ultimately have
          2: "S.seq (Cones.map g) (Φo (Cop.dom g)) 
              Cones.map g S Φo (Cop.dom g) = S.mkArr ?A ?C (?F' o ?G')"
          using S.seqI' [of "Φo (Cop.dom g)" "Cones.map g"] S.comp_mkArr by auto

        have "Φo (Cop.cod g) S Y a g = S.mkArr ?A ?C (?G o ?F)"
          using 1 by auto
        also have "... = S.mkArr ?A ?C (?F' o ?G')"
        proof (intro S.mkArr_eqI')
          show "S.arr (S.mkArr ?A ?C (?G o ?F))" using 1 by force
          show "x. x  ?A  (?G o ?F) x = (?F' o ?G') x"
          proof -
            fix x
            assume x: "x  ?A"
            hence 1: "«ψ (C.cod g, a) x : C.cod g  a»"
              using ide_apex g Hom.ψ_mapsto [of "C.cod g" a] by auto
            have "(?G o ?F) x = ι (D.cones_map (ψ (C.dom g, a)
                                  (φ (C.dom g, a) (ψ (C.cod g, a) x  g))) χ)"
            proof - (* Why is it so balky with this proof? *)
              have "(?G o ?F) x = ?G (?F x)" by simp
              also have "... = ι (D.cones_map (ψ (C.dom g, a)
                                     (φ (C.dom g, a) (ψ (C.cod g, a) x  g))) χ)"
              proof -
                have "?F x = φ (C.dom g, a) (ψ (C.cod g, a) x  g)" by simp
                thus ?thesis by presburger (* presburger 5ms, metis 797ms! Why? *)
              qed
              finally show ?thesis by auto
            qed
            also have "... = ι (D.cones_map (ψ (C.cod g, a) x  g) χ)"
            proof -
              have "«ψ (C.cod g, a) x  g : C.dom g  a»" using g 1 by auto
              thus ?thesis using Hom.ψ_φ by presburger
            qed
            also have "... = ι (D.cones_map g (D.cones_map (ψ (C.cod g, a) x) χ))"
              using g x 1 cone_χ D.cones_map_comp [of (C.cod g, a) x" g] by fastforce
            also have "... = ι (D.cones_map g (𝗈 (ι (D.cones_map (ψ (C.cod g, a) x) χ))))"
              using 1 cone_χ D.cones_map_mapsto Sr.𝗈_ι by auto
            also have "... = (?F' o ?G') x" by simp
            finally show "(?G o ?F) x = (?F' o ?G') x" by auto
          qed
        qed
        also have "... = Cones.map g S Φo (Cop.dom g)"
          using 2 by auto
       finally show ?thesis by auto
      qed
    qed

    interpretation Φ: set_valued_transformation Cop.comp S.comp ‹Y a Cones.map Φ.map ..
                                            
    interpretation Φ: natural_isomorphism Cop.comp S.comp ‹Y a Cones.map Φ.map
    proof
      fix a'
      assume a': "Cop.ide a'"
      show "S.iso (Φ.map a')"
      proof -
        let ?F = "λx. ι (D.cones_map (ψ (a', a) x) χ)"
        have bij: "bij_betw ?F (Hom.set (a', a)) (ι ` D.cones a')"
        proof -
          have "x x'.  x  Hom.set (a', a); x'  Hom.set (a', a);
                         ι (D.cones_map (ψ (a', a) x) χ) = ι (D.cones_map (ψ (a', a) x') χ) 
                             x = x'"
          proof -
            fix x x'
            assume x: "x  Hom.set (a', a)" and x': "x'  Hom.set (a', a)"
            and xx': (D.cones_map (ψ (a', a) x) χ) = ι (D.cones_map (ψ (a', a) x') χ)"
            have ψx: "«ψ (a', a) x : a'  a»" using x ide_apex a' Hom.ψ_mapsto by auto
            have ψx': "«ψ (a', a) x' : a'  a»" using x' ide_apex a' Hom.ψ_mapsto by auto
            have 1: "∃!f. «f : a'  a»  ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ)"
            proof -
              have "D.cones_map (ψ (a', a) x) χ  D.cones a'"
                using ψx a' cone_χ D.cones_map_mapsto by force
              hence 2: "∃!f. «f : a'  a»  D.cones_map f χ = D.cones_map (ψ (a', a) x) χ"
                using a' is_universal by simp
              show "∃!f. «f : a'  a»  ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ)"
              proof -
                have "f. ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ)
                              D.cones_map f χ = D.cones_map (ψ (a', a) x) χ"
                proof -
                  fix f :: 'c
                  have "D.cones_map f χ = D.cones_map (ψ (a', a) x) χ
                            ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ)"
                    by simp
                  thus "(ι (D.cones_map f χ) = ι (D.cones_map (ψ (a', a) x) χ))
                            = (D.cones_map f χ = D.cones_map (ψ (a', a) x) χ)"
                    by (meson Sr.inj_ι injD)
                qed
                thus ?thesis using 2 by auto
              qed
            qed
            have 2: "∃!x''. x''  Hom.set (a', a) 
                            ι (D.cones_map (ψ (a', a) x'') χ) = ι (D.cones_map (ψ (a', a) x) χ)"
            proof -
              from 1 obtain f'' where
                  f'': "«f'' : a'  a»  ι (D.cones_map f'' χ) = ι (D.cones_map (ψ (a', a) x) χ)"
                by blast
              have (a', a) f''  Hom.set (a', a) 
                    ι (D.cones_map (ψ (a', a) (φ (a', a) f'')) χ) = ι (D.cones_map (ψ (a', a) x) χ)"
              proof
                show (a', a) f''  Hom.set (a', a)" using f'' Hom.set_def by auto
                show (D.cones_map (ψ (a', a) (φ (a', a) f'')) χ) =
                         ι (D.cones_map (ψ (a', a) x) χ)"
                  using f'' Hom.ψ_φ by presburger
              qed
              moreover have
                 "x''. x''  Hom.set (a', a) 
                         ι (D.cones_map (ψ (a', a) x'') χ) = ι (D.cones_map (ψ (a', a) x) χ)
                              x'' = φ (a', a) f''"
              proof -
                fix x''
                assume x'': "x''  Hom.set (a', a) 
                             ι (D.cones_map (ψ (a', a) x'') χ) = ι (D.cones_map (ψ (a', a) x) χ)"
                hence "«ψ (a', a) x'' : a'  a» 
                       ι (D.cones_map (ψ (a', a) x'') χ) = ι (D.cones_map (ψ (a', a) x) χ)"
                  using ide_apex a' Hom.set_def Hom.ψ_mapsto [of a' a] by auto
                hence (a', a) (ψ (a', a) x'') = φ (a', a) f''"
                  using 1 f'' by auto
                thus "x'' = φ (a', a) f''"
                  using ide_apex a' x'' Hom.φ_ψ by simp
              qed
              ultimately show ?thesis
                using ex1I [of "λx'. x'  Hom.set (a', a) 
                                     ι (D.cones_map (ψ (a', a) x') χ) =
                                        ι (D.cones_map (ψ (a', a) x) χ)"
                               (a', a) f''"]
                by simp
            qed
            thus "x = x'" using x x' xx' by auto
          qed
          hence "inj_on ?F (Hom.set (a', a))"
            using inj_onI [of "Hom.set (a', a)" ?F] by auto 
          moreover have "?F ` Hom.set (a', a) = ι ` D.cones a'"
          proof
            show "?F ` Hom.set (a', a)  ι ` D.cones a'"
            proof
              fix X'
              assume X': "X'  ?F ` Hom.set (a', a)"
              from this obtain x' where x': "x'  Hom.set (a', a)  ?F x' = X'" by blast
              show "X'  ι ` D.cones a'"
              proof -
                have "X' = ι (D.cones_map (ψ (a', a) x') χ)" using x' by blast
                hence "X' = ι (D.cones_map (ψ (a', a) x') χ)" using x' by force
                moreover have "«ψ (a', a) x' : a'  a»"
                  using ide_apex a' x' Hom.set_def Hom.ψ_φ by auto
                ultimately show ?thesis
                  using x' cone_χ D.cones_map_mapsto by force
              qed
            qed
            show ` D.cones a'  ?F ` Hom.set (a', a)"
            proof
              fix X'
              assume X': "X'  ι ` D.cones a'"
              hence "𝗈 X'  𝗈 ` ι ` D.cones a'" by simp
              with Sr.𝗈_ι have "𝗈 X'  D.cones a'"
                by auto
              hence "∃!f. «f : a'  a»  D.cones_map f χ = 𝗈 X'"
                using a' is_universal by simp
              from this obtain f where "«f : a'  a»  D.cones_map f χ = 𝗈 X'"
                by auto
              hence f: "«f : a'  a»  ι (D.cones_map f χ) = X'"
                using X' Sr.ι_𝗈 by auto
              have "X' = ?F (φ (a', a) f)"
                using f Hom.ψ_φ by presburger
              thus "X'  ?F ` Hom.set (a', a)"
                using f Hom.set_def by force
            qed
          qed
          ultimately show ?thesis
            using bij_betw_def [of ?F "Hom.set (a', a)" ` D.cones a'"] inj_on_def by auto
        qed
        let ?f = "S.mkArr (Hom.set (a', a)) (ι ` D.cones a') ?F"
        have iso: "S.iso ?f"
        proof -
          have "?F  Hom.set (a', a)  ι ` D.cones a'"
            using bij bij_betw_imp_funcset by fast
          hence 1: "S.arr ?f"
            using ide_apex a' Hom.set_subset_Univ S.ι_mapsto S.arr_mkArr by auto
          thus ?thesis using bij S.iso_char S.arr_mkArr S.set_mkIde by fastforce
        qed
        moreover have "?f = Φ.map a'"
          using a' Φo_def by force
        finally show ?thesis by auto
      qed
    qed

    interpretation R: representation_of_functor C S.comp φ Cones.map a Φ.map ..

    lemma χ_in_terms_of_Φ:
    shows "χ = 𝗈 (Φ.FUN a (φ (a, a) a))"
    proof -
      have "Φ.FUN a (φ (a, a) a) = 
              (λx  Hom.set (a, a). ι (D.cones_map (ψ (a, a) x) χ)) (φ (a, a) a)"
        using ide_apex S.Fun_mkArr Φ.map_simp_ide Φo_def Φ.preserves_reflects_arr [of a]
        by simp
      also have "... = ι (D.cones_map a χ)"
      proof -
        have (a, a) a  Hom.set (a, a)"
          using ide_apex Hom.φ_mapsto by fastforce
        hence "(λx  Hom.set (a, a). ι (D.cones_map (ψ (a, a) x) χ)) (φ (a, a) a)
                  = ι (D.cones_map (ψ (a, a) (φ (a, a) a)) χ)"
          using restrict_apply' [of (a, a) a" "Hom.set (a, a)"] by blast
        also have "... = ι (D.cones_map a χ)"
        proof -
          have (a, a) (φ (a, a) a) = a"
            using ide_apex Hom.ψ_φ [of a a a] by fastforce
          thus ?thesis by metis
        qed
        finally show ?thesis by auto
      qed
      finally have "Φ.FUN a (φ (a, a) a) = ι (D.cones_map a χ)" by auto
      also have "... = ι χ"
        using ide_apex D.cones_map_ide [of χ a] cone_χ by simp
      finally have "Φ.FUN a (φ (a, a) a) = ι χ" by blast
      hence "𝗈 (Φ.FUN a (φ (a, a) a)) = 𝗈 (ι χ)" by simp
      thus ?thesis using cone_χ Sr.𝗈_ι by simp
    qed

    abbreviation Hom
    where "Hom  Hom.map"

    abbreviation Φ
    where "Φ  Φ.map"

    lemma induces_limit_situation:
    shows "limit_situation J C D S.comp φ ι a Φ χ"
    proof
      show "χ = 𝗈 (Φ.FUN a (φ (a, a) a))" using χ_in_terms_of_Φ by auto
      fix a'
      show "Cop.ide a'  Φ.map a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a')
                                              (λx. ι (D.cones_map (ψ (a', a) x) χ))"
        using Φ.map_simp_ide Φo_def [of a'] by force
    qed

    no_notation S.comp      (infixr "S" 55)

  end

  sublocale limit_cone  limit_situation J C D replete_setcat.comp φ ι a Φ χ
    using induces_limit_situation by auto

  subsection "Representations of the Cones Functor Induce Limit Situations"

  context representation_of_cones_functor
  begin

    interpretation Φ: set_valued_transformation Cop.comp S ‹Y a Cones.map Φ ..
    interpretation Ψ: inverse_transformation Cop.comp S ‹Y a Cones.map Φ ..
    interpretation Ψ: set_valued_transformation Cop.comp S Cones.map ‹Y a Ψ.map ..

    abbreviation 𝗈
    where "𝗈  Cones.𝗈"

    abbreviation χ
    where "χ  𝗈 (S.Fun (Φ a) (φ (a, a) a))"

    lemma Cones_SET_eq_ι_img_cones:
    assumes "C.ide a'"
    shows "Cones.SET a' = ι ` D.cones a'"
    proof -
      have "ι ` D.cones a'  S.Univ" using S.ι_mapsto by auto
      thus ?thesis using assms Cones.map_ide S.set_mkIde by auto
    qed

    lemma ιχ:
    shows "ι χ = S.Fun (Φ a) (φ (a, a) a)"
    proof -
      have "S.Fun (Φ a) (φ (a, a) a)  Cones.SET a"
        using Ya.ide_a Hom.φ_mapsto S.Fun_mapsto [of "Φ a"] Hom.set_map by fastforce
      thus ?thesis
        using Ya.ide_a Cones_SET_eq_ι_img_cones by auto
    qed

    interpretation χ: cone J C D a χ
    proof -
      have "ι χ  ι ` D.cones a"
        using Ya.ide_a ιχ S.Fun_mapsto [of "Φ a"] Hom.φ_mapsto Hom.set_map
              Cones_SET_eq_ι_img_cones by fastforce
      thus "D.cone a χ"
        by (metis S.𝗈_ι UNIV_I imageE mem_Collect_eq)
    qed

    lemma cone_χ:
    shows "D.cone a χ" ..

    lemma Φ_FUN_simp:
    assumes a': "C.ide a'" and x: "x  Hom.set (a', a)"
    shows "Φ.FUN a' x = Cones.FUN (ψ (a', a) x) (ι χ)"
    proof -
      have ψx: "«ψ (a', a) x : a'  a»"
        using Ya.ide_a a' x Hom.ψ_mapsto by blast
      have φa: "φ (a, a) a  Hom.set (a, a)" using Ya.ide_a Hom.φ_mapsto by fastforce
      have "Φ.FUN a' x = (Φ.FUN a' o Ya.FUN (ψ (a', a) x)) (φ (a, a) a)"
      proof -
        have "φ (a', a) (a  ψ (a', a) x) = x"
          using Ya.ide_a a' x ψx Hom.φ_ψ C.comp_cod_arr by fastforce
        moreover have "S.arr (S.mkArr (Hom.set (a, a)) (Hom.set (a', a))
                             (φ (a', a)  Cop.comp (ψ (a', a) x)  ψ (a, a)))"
          by (metis (no_types) Cop.hom_char Ya.Y_ide_arr(2) Ya.preserves_reflects_arr
              χ.ide_apex ψx Cop.in_homE)
        ultimately show ?thesis
          using Ya.ide_a a' x Ya.Y_ide_arr ψx φa C.ide_in_hom by auto
      qed
      also have "... = (Cones.FUN (ψ (a', a) x) o Φ.FUN a) (φ (a, a) a)"
      proof -
        have "(Φ.FUN a' o Ya.FUN (ψ (a', a) x)) (φ (a, a) a)
                = S.Fun (Φ a' S Y a (ψ (a', a) x)) (φ (a, a) a)"
          using ψx a' φa Ya.ide_a Ya.map_simp Hom.set_map by (elim C.in_homE, auto)
        also have "... = S.Fun (S (Cones.map (ψ (a', a) x)) (Φ a)) (φ (a, a) a)"
          using ψx is_natural_1 [of (a', a) x"] is_natural_2 [of (a', a) x"] by auto
        also have "... = (Cones.FUN (ψ (a', a) x) o Φ.FUN a) (φ (a, a) a)"
        proof -
          have "S.seq (Cones.map (ψ (a', a) x)) (Φ a)"
            using Ya.ide_a ψx Cones.map_preserves_dom [of (a', a) x"]
            apply (intro S.seqI)
              apply auto[2]
            by fastforce
          thus ?thesis
            using Ya.ide_a φa Hom.set_map by auto
        qed
        finally show ?thesis by simp
      qed
      also have "... = Cones.FUN (ψ (a', a) x) (ι χ)" using ιχ by simp
      finally show ?thesis by auto
    qed

    lemma χ_is_universal:
    assumes "D.cone a' χ'"
    shows "«ψ (a', a) (Ψ.FUN a' (ι χ')) : a'  a»"
    and "D.cones_map (ψ (a', a) (Ψ.FUN a' (ι χ'))) χ = χ'"
    and " «f' : a'  a»; D.cones_map f' χ = χ'   f' = ψ (a', a) (Ψ.FUN a' (ι χ'))"
    proof -
      interpret χ': cone J C D a' χ' using assms by auto
      have a': "C.ide a'" using χ'.ide_apex by simp
      have ιχ': "ι χ'  Cones.SET a'" using assms a' Cones_SET_eq_ι_img_cones by auto
      let ?f = (a', a) (Ψ.FUN a' (ι χ'))"
      have A: "Ψ.FUN a' (ι χ')  Hom.set (a', a)"
      proof -
        have "Ψ.FUN a'  Cones.SET a'  Ya.SET a'"
          using a' Ψ.preserves_hom [of a' a' a'] S.Fun_mapsto [of "Ψ.map a'"] by fastforce
        thus ?thesis using a' ιχ' Ya.ide_a Hom.set_map by auto
      qed
      show f: "«?f : a'  a»" using A a' Ya.ide_a Hom.ψ_mapsto [of a' a] by auto
      have E: "f. «f : a'  a»  Cones.FUN f (ι χ) = Φ.FUN a' (φ (a', a) f)"
      proof -
        fix f
        assume f: "«f : a'  a»"
        have "φ (a', a) f  Hom.set (a', a)"
          using a' Ya.ide_a f Hom.φ_mapsto by auto
        thus "Cones.FUN f (ι χ) = Φ.FUN a' (φ (a', a) f)"
          using a' f Φ_FUN_simp by simp
      qed
      have I: "Φ.FUN a' (Ψ.FUN a' (ι χ')) = ι χ'"
      proof -
        have "Φ.FUN a' (Ψ.FUN a' (ι χ')) =
              compose (Ψ.DOM a') (Φ.FUN a') (Ψ.FUN a') (ι χ')"
          using a' ιχ' Cones.map_ide Ψ.preserves_hom [of a' a' a'] by force
        also have "... = (λx  Ψ.DOM a'. x) (ι χ')"
          using a' Ψ.inverts_components S.inverse_arrows_char by force
        also have "... = ι χ'"
          using a' ιχ' Cones.map_ide Ψ.preserves_hom [of a' a' a'] by force
        finally show ?thesis by auto
      qed
      show: "D.cones_map ?f χ = χ'"
      proof -
        have "D.cones_map ?f χ = (𝗈 o Cones.FUN ?f o ι) χ"
          using f Cones.preserves_arr [of ?f] cone_χ
          by (cases "D.cone a χ", auto)
        also have "... = χ'"
           using f Ya.ide_a a' A E I by auto
        finally show ?thesis by auto
      qed
      show " «f' : a'  a»; D.cones_map f' χ = χ'   f' = ?f"
      proof -
        assume f': "«f' : a'  a»" and f'χ: "D.cones_map f' χ = χ'"
        show "f' = ?f"
        proof -
          have 1: "φ (a', a) f'  Hom.set (a', a)  φ (a', a) ?f  Hom.set (a', a)"
            using Ya.ide_a a' f f' Hom.φ_mapsto by auto
          have "S.iso (Φ a')" using χ'.ide_apex components_are_iso by auto
          hence 2: "S.arr (Φ a')  bij_betw (Φ.FUN a') (Hom.set (a', a)) (Cones.SET a')"
            using Ya.ide_a a' S.iso_char Hom.set_map by auto
          have "Φ.FUN a' (φ (a', a) f') = Φ.FUN a' (φ (a', a) ?f)"
          proof -
            have "Φ.FUN a' (φ (a', a) ?f) = ι χ'"
              using A I Hom.φ_ψ Ya.ide_a a' by simp
            also have "... = Cones.FUN f' (ι χ)"
              using f f' A E cone_χ Cones.preserves_arr fχ f'χ by (elim C.in_homE, auto)
            also have "... = Φ.FUN a' (φ (a', a) f')"
              using f' E by simp
            finally show ?thesis by argo
          qed
          moreover have "inj_on (Φ.FUN a') (Hom.set (a', a))"
            using 2 bij_betw_imp_inj_on by blast
          ultimately have 3: "φ (a', a) f' = φ (a', a) ?f"
            using 1 inj_on_def [of "Φ.FUN a'" "Hom.set (a', a)"] by blast
          show ?thesis
          proof -
            have "f' = ψ (a', a) (φ (a', a) f')"
              using Ya.ide_a a' f' Hom.ψ_φ by simp
            also have "... = ψ (a', a) (Ψ.FUN a' (ι χ'))"
              using Ya.ide_a a' Hom.ψ_φ A 3 by simp
            finally show ?thesis by blast
          qed
        qed
      qed
    qed

    interpretation χ: limit_cone J C D a χ
    proof
      show "a' χ'. D.cone a' χ'  ∃!f. «f : a'  a»  D.cones_map f χ = χ'"
      proof -
        fix a' χ'
        assume 1: "D.cone a' χ'"
        show "∃!f. «f : a'  a»  D.cones_map f χ = χ'"
        proof
          show "«ψ (a', a) (Ψ.FUN a' (ι χ')) : a'  a» 
                D.cones_map (ψ (a', a) (Ψ.FUN a' (ι χ'))) χ = χ'"
            using 1 χ_is_universal by blast
          show "f. «f : a'  a»  D.cones_map f χ = χ'  f = ψ (a', a) (Ψ.FUN a' (ι χ'))"
            using 1 χ_is_universal by blast
        qed
      qed
    qed

    lemma χ_is_limit_cone:
    shows "D.limit_cone a χ" ..

    lemma induces_limit_situation:
    shows "limit_situation J C D S φ ι a Φ χ"
    proof
      show = χ" by simp
      fix a'
      assume a': "Cop.ide a'"
      let ?F = "λx. ι (D.cones_map (ψ (a', a) x) χ)"
      show "Φ a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') ?F"
      proof -
        have 1: "«Φ a' : S.mkIde (Hom.set (a', a)) S S.mkIde (ι ` D.cones a')»"
          using a' Cones.map_ide Ya.ide_a by auto
        moreover have "Φ.DOM a' = Hom.set (a', a)"
          using 1 Hom.set_subset_Univ a' Ya.ide_a Hom.set_map by simp
        moreover have "Φ.COD a' = ι ` D.cones a'"
          using a' Cones_SET_eq_ι_img_cones by fastforce
        ultimately have 2: "Φ a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') (Φ.FUN a')"
          using S.mkArr_Fun [of "Φ a'"] by fastforce
        also have "... = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') ?F"
        proof
          show "S.arr (S.mkArr (Hom.set (a', a)) (ι ` D.cones a') (Φ.FUN a'))"
            using 1 2 by auto
          show "x. x  Hom.set (a', a)  Φ.FUN a' x = ?F x"
          proof -
            fix x
            assume x: "x  Hom.set (a', a)"
            hence ψx: "«ψ (a', a) x : a'  a»"
              using a' Ya.ide_a Hom.ψ_mapsto by auto
            show "Φ.FUN a' x = ?F x"
            proof -
              have "Φ.FUN a' x = Cones.FUN (ψ (a', a) x) (ι χ)"
                using a' x Φ_FUN_simp by simp
              also have "... = restrict (ι o D.cones_map (ψ (a', a) x) o 𝗈) (ι ` D.cones a) (ι χ)"
                using ψx Cones.map_simp Cones.preserves_arr [of (a', a) x"] S.Fun_mkArr
                by (elim C.in_homE, auto)
              also have "... = ?F x" using cone_χ by simp
              ultimately show ?thesis by simp
            qed
          qed
        qed
        finally show "Φ a' = S.mkArr (Hom.set (a', a)) (ι ` D.cones a') ?F" by auto
      qed
    qed

  end

  sublocale representation_of_cones_functor  limit_situation J C D S φ ι a Φ χ
    using induces_limit_situation by auto

  section "Categories with Limits"

  context category
  begin

    text‹
      A category @{term[source=true] C} has limits of shape @{term J} if every diagram of shape
      @{term J} admits a limit cone.
›

    definition has_limits_of_shape
    where "has_limits_of_shape J  D. diagram J C D  (a χ. limit_cone J C D a χ)"

    text‹
      A category has limits at a type @{typ 'j} if it has limits of shape @{term J}
      for every category @{term J} whose arrows are of type @{typ 'j}.
›

    definition has_limits
    where "has_limits (_ :: 'j)  J :: 'j comp. category J  has_limits_of_shape J"

    text‹
      Whether a category has limits of shape J› truly depends only on the ``shape''
      (\emph{i.e.}~isomorphism class) of J› and not on details of its construction.
    ›

    lemma has_limits_preserved_by_isomorphism:
    assumes "has_limits_of_shape J" and "isomorphic_categories J J'"
    shows "has_limits_of_shape J'"
    proof -
      interpret J: category J
        using assms(2) isomorphic_categories_def isomorphic_categories_axioms_def by auto
      interpret J': category J'
        using assms(2) isomorphic_categories_def isomorphic_categories_axioms_def by auto
      from assms(2) obtain φ ψ where IF: "inverse_functors J' J φ ψ"
        using isomorphic_categories_def isomorphic_categories_axioms_def
              inverse_functors_sym
        by blast
      interpret IF: inverse_functors J' J φ ψ using IF by auto
      have ψφ: "ψ o φ = J.map" using IF.inv by metis
      have φψ: "φ o ψ = J'.map" using IF.inv' by metis
      have "D'. diagram J' C D'  a χ. limit_cone J' C D' a χ"
      proof -
        fix D'
        assume D': "diagram J' C D'"
        interpret D': diagram J' C D' using D' by auto
        interpret D: composite_functor J J' C φ D' ..
        interpret D: diagram J C D' o φ ..
        have D: "diagram J C (D' o φ)" ..
        from assms(1) obtain a χ where χ: "D.limit_cone a χ"
          using D has_limits_of_shape_def by blast
        interpret χ: limit_cone J C D' o φ a χ using χ by auto
        interpret A': constant_functor J' C a
          using χ.ide_apex by (unfold_locales, auto)
        have χoψ: "cone J' C (D' o φ o ψ) a (χ o ψ)"
          using comp_cone_functor IF.G.functor_axioms χ.cone_axioms by fastforce
        hence χoψ: "cone J' C D' a (χ o ψ)"
          using φψ by (metis D'.functor_axioms Fun.comp_assoc comp_functor_identity)
        interpret χoψ: cone J' C D' a χ o ψ using χoψ by auto
        interpret χoψ: limit_cone J' C D' a χ o ψ
        proof
          fix a' χ'
          assume χ': "D'.cone a' χ'"
          interpret χ': cone J' C D' a' χ' using χ' by auto
          have χ'oφ: "cone J C (D' o φ) a' (χ' o φ)"
            using χ' comp_cone_functor IF.F.functor_axioms by fastforce
          interpret χ'oφ: cone J C D' o φ a' χ' o φ using χ'oφ by auto
          have "cone J C (D' o φ) a' (χ' o φ)" ..
          hence 1: "∃!f. «f : a'  a»  D.cones_map f χ = χ' o φ"
            using χ.is_universal by simp
          show "∃!f. «f : a'  a»  D'.cones_map f (χ o ψ) = χ'"
          proof
            let ?f = "THE f. «f : a'  a»  D.cones_map f χ = χ' o φ"
            have f: "«?f : a'  a»  D.cones_map ?f χ = χ' o φ"
              using 1 theI' [of "λf. «f : a'  a»  D.cones_map f χ = χ' o φ"] by blast
            have f_in_hom: "«?f : a'  a»" using f by blast
            have "D'.cones_map ?f (χ o ψ) = χ'"
            proof
              fix j'
              have "¬J'.arr j'  D'.cones_map ?f (χ o ψ) j' = χ' j'"
              proof -
                assume j': "¬J'.arr j'"
                have "D'.cones_map ?f (χ o ψ) j' = null"
                  using j' f_in_hom χoψ by fastforce
                thus ?thesis
                  using j' χ'.is_extensional by simp
              qed
              moreover have "J'.arr j'  D'.cones_map ?f (χ o ψ) j' = χ' j'"
              proof -
                assume j': "J'.arr j'"
                have "D'.cones_map ?f (χ o ψ) j' = χ (ψ j')  ?f"
                  using j' f χoψ by fastforce
                also have "... = D.cones_map ?f χ (ψ j')"
                  using j' f_in_hom χ χ.cone_χ by fastforce
                also have "... = χ' j'"
                  using j' f χ φψ Fun.comp_def J'.map_simp by metis
                finally show "D'.cones_map ?f (χ o ψ) j' = χ' j'" by auto
              qed
              ultimately show "D'.cones_map ?f (χ o ψ) j' = χ' j'" by blast
            qed
            thus "«?f : a'  a»  D'.cones_map ?f (χ o ψ) = χ'" using f by auto
            fix f'
            assume f': "«f' : a'  a»  D'.cones_map f' (χ o ψ) = χ'"
            have "D.cones_map f' χ = χ' o φ"
            proof
              fix j
              have "¬J.arr j  D.cones_map f' χ j = (χ' o φ) j"
                using f' χ χ'oφ.is_extensional χ.cone_χ mem_Collect_eq restrict_apply by auto
              moreover have "J.arr j  D.cones_map f' χ j = (χ' o φ) j"
              proof -
                assume j: "J.arr j"
                have "D.cones_map f' χ j = C (χ j) f'"
                  using j f' χ.cone_χ by auto
                also have "... = C ((χ o ψ) (φ j)) f'"
                  using j f' ψφ by (metis comp_apply J.map_simp)
                also have "... = D'.cones_map f' (χ o ψ) (φ j)"
                  using j f' χoψ by fastforce
                also have "... = (χ' o φ) j"
                  using j f' by auto
                finally show "D.cones_map f' χ j = (χ' o φ) j" by auto
              qed
              ultimately show "D.cones_map f' χ j = (χ' o φ) j" by blast
            qed
            hence "«f' : a'  a»  D.cones_map f' χ = χ' o φ"
              using f' by auto
            moreover have "P x x'. (∃!x. P x)  P x  P x'  x = x'"
              by auto
            ultimately show "f' = ?f" using 1 f by blast
          qed
        qed
        have "limit_cone J' C D' a (χ o ψ)" ..
        thus "a χ. limit_cone J' C D' a χ" by blast
      qed
      thus ?thesis using has_limits_of_shape_def by auto
    qed

  end

  subsection "Diagonal Functors"

  text‹
    The existence of limits can also be expressed in terms of adjunctions: a category @{term C}
    has limits of shape @{term J} if the diagonal functor taking each object @{term a}
    in @{term C} to the constant-@{term a} diagram and each arrow f ∈ C.hom a a'›
    to the constant-@{term f} natural transformation between diagrams is a left adjoint functor.
›

  locale diagonal_functor =
    C: category C +
    J: category J +
    J_C: functor_category J C
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  begin

    notation J.in_hom     ("«_ : _ J _»")
    notation J_C.comp     (infixr "[J,C]" 55)
    notation J_C.in_hom   ("«_ : _ [J,C] _»")

    definition map :: "'c  ('j, 'c) J_C.arr"
    where "map f = (if C.arr f then J_C.MkArr (constant_functor.map J C (C.dom f))
                                              (constant_functor.map J C (C.cod f))
                                              (constant_transformation.map J C f)
                               else J_C.null)"

    lemma is_functor:
    shows "functor C J_C.comp map"
    proof
      fix f
      show "¬ C.arr f  local.map f = J_C.null"
        using map_def by simp
      assume f: "C.arr f"
      interpret Dom_f: constant_functor J C ‹C.dom f
        using f by (unfold_locales, auto)
      interpret Cod_f: constant_functor J C ‹C.cod f
        using f by (unfold_locales, auto)
      interpret Fun_f: constant_transformation J C f
        using f by (unfold_locales, auto)
      show 1: "J_C.arr (map f)"
        using f map_def by (simp add: Fun_f.natural_transformation_axioms)
      show "J_C.dom (map f) = map (C.dom f)"
      proof -
        have "constant_transformation J C (C.dom f)"
          apply unfold_locales using f by auto
        hence "constant_transformation.map J C (C.dom f) = Dom_f.map"
          using Dom_f.map_def constant_transformation.map_def [of J C "C.dom f"] by auto
        thus ?thesis using f 1 by (simp add: map_def J_C.dom_char)
      qed
      show "J_C.cod (map f) = map (C.cod f)"
      proof -
        have "constant_transformation J C (C.cod f)"
          apply unfold_locales using f by auto
        hence "constant_transformation.map J C (C.cod f) = Cod_f.map"
          using Cod_f.map_def constant_transformation.map_def [of J C "C.cod f"] by auto
        thus ?thesis using f 1 by (simp add: map_def J_C.cod_char)
      qed
      next
      fix f g
      assume g: "C.seq g f"
      have f: "C.arr f" using g by auto
      interpret Dom_f: constant_functor J C ‹C.dom f
        using f by (unfold_locales, auto)
      interpret Cod_f: constant_functor J C ‹C.cod f
        using f by (unfold_locales, auto)
      interpret Fun_f: constant_transformation J C f
        using f by (unfold_locales, auto)
      interpret Cod_g: constant_functor J C ‹C.cod g
        using g by (unfold_locales, auto)
      interpret Fun_g: constant_transformation J C g
        using g by (unfold_locales, auto)
      interpret Fun_g: natural_transformation J C Cod_f.map Cod_g.map Fun_g.map
        apply unfold_locales
        using f g C.seqE [of g f] C.comp_arr_dom C.comp_cod_arr Fun_g.is_extensional by auto
      interpret Fun_fg: vertical_composite
                          J C Dom_f.map Cod_f.map Cod_g.map Fun_f.map Fun_g.map ..
      have 1: "J_C.arr (map f)"
        using f map_def by (simp add: Fun_f.natural_transformation_axioms)
      show "map (g  f) = map g [J,C] map f"
      proof -
        have "map (C g f) = J_C.MkArr Dom_f.map Cod_g.map
                                      (constant_transformation.map J C (C g f))"
          using f g map_def by simp
        also have "... = J_C.MkArr Dom_f.map Cod_g.map (λj. if J.arr j then C g f else C.null)"
        proof -
          have "constant_transformation J C (g  f)"
            apply unfold_locales using g by auto
          thus ?thesis using constant_transformation.map_def by metis
        qed
        also have "... = J_C.comp (J_C.MkArr Cod_f.map Cod_g.map Fun_g.map)
                                  (J_C.MkArr Dom_f.map Cod_f.map Fun_f.map)"
        proof -
          have "J_C.MkArr Cod_f.map Cod_g.map Fun_g.map [J,C]
                J_C.MkArr Dom_f.map Cod_f.map Fun_f.map
                  = J_C.MkArr Dom_f.map Cod_g.map Fun_fg.map"
            using J_C.comp_char J_C.comp_MkArr Fun_f.natural_transformation_axioms
                  Fun_g.natural_transformation_axioms
            by blast
          also have "... = J_C.MkArr Dom_f.map Cod_g.map
                                     (λj. if J.arr j then g  f else C.null)"
          proof -
            have "Fun_fg.map = (λj. if J.arr j then g  f else C.null)"
              using 1 f g Fun_fg.map_def by auto
            thus ?thesis by auto
          qed
          finally show ?thesis by auto
        qed
        also have "... = map g [J,C] map f"
          using f g map_def by fastforce
        finally show ?thesis by auto
      qed
    qed

    sublocale "functor" C J_C.comp map
      using is_functor by auto

    text‹
      The objects of [J, C]› correspond bijectively to diagrams of shape @{term J}
      in @{term C}.
›

    lemma ide_determines_diagram:
    assumes "J_C.ide d"
    shows "diagram J C (J_C.Map d)" and "J_C.MkIde (J_C.Map d) = d"
    proof -
      interpret δ: natural_transformation J C ‹J_C.Map d ‹J_C.Map d ‹J_C.Map d
        using assms J_C.ide_char J_C.arr_MkArr by fastforce
      interpret D: "functor" J C ‹J_C.Map d ..
      show "diagram J C (J_C.Map d)" ..
      show "J_C.MkIde (J_C.Map d) = d"
        using assms J_C.ide_char by (metis J_C.ideD(1) J_C.MkArr_Map)
    qed

    lemma diagram_determines_ide:
    assumes "diagram J C D"
    shows "J_C.ide (J_C.MkIde D)" and "J_C.Map (J_C.MkIde D) = D"
    proof -
      interpret D: diagram J C D using assms by auto
      show "J_C.ide (J_C.MkIde D)" using J_C.ide_char
        using D.functor_axioms J_C.ide_MkIde by auto
      thus "J_C.Map (J_C.MkIde D) = D"
        using J_C.in_homE by simp
    qed

    lemma bij_betw_ide_diagram:
    shows "bij_betw J_C.Map (Collect J_C.ide) (Collect (diagram J C))"
    proof (intro bij_betwI)
      show "J_C.Map  Collect J_C.ide  Collect (diagram J C)"
        using ide_determines_diagram by blast
      show "J_C.MkIde  Collect (diagram J C)  Collect J_C.ide"
        using diagram_determines_ide by blast
      show "d. d  Collect J_C.ide  J_C.MkIde (J_C.Map d) = d"
        using ide_determines_diagram by blast
      show "D. D  Collect (diagram J C)  J_C.Map (J_C.MkIde D) = D"
        using diagram_determines_ide by blast
    qed

    text‹
      Arrows from from the diagonal functor correspond bijectively to cones.
›

    lemma arrow_determines_cone:
    assumes "J_C.ide d" and "arrow_from_functor C J_C.comp map a d x"
    shows "cone J C (J_C.Map d) a (J_C.Map x)"
    and "J_C.MkArr (constant_functor.map J C a) (J_C.Map d) (J_C.Map x) = x"
    proof -
      interpret D: diagram J C ‹J_C.Map d
        using assms ide_determines_diagram by auto
      interpret x: arrow_from_functor C J_C.comp map a d x
        using assms by auto
      interpret A: constant_functor J C a
        using x.arrow by (unfold_locales, auto)
      interpret α: constant_transformation J C a
        using x.arrow by (unfold_locales, auto)
      have Dom_x: "J_C.Dom x = A.map"
      proof -
        have "J_C.dom x = map a" using x.arrow by blast
        hence "J_C.Map (J_C.dom x) = J_C.Map (map a)" by simp
        hence "J_C.Dom x = J_C.Map (map a)"
          using A.value_is_ide x.arrow J_C.in_homE by (metis J_C.Map_dom)
        moreover have "J_C.Map (map a) = α.map"
          using A.value_is_ide preserves_ide map_def by simp
        ultimately show ?thesis using α.map_def A.map_def by auto
      qed
      have Cod_x: "J_C.Cod x = J_C.Map d"
        using x.arrow by auto
      interpret χ: natural_transformation J C A.map ‹J_C.Map d ‹J_C.Map x
        using x.arrow J_C.arr_char [of x] Dom_x Cod_x by force
      show "D.cone a (J_C.Map x)" ..
      show "J_C.MkArr A.map (J_C.Map d) (J_C.Map x) = x"
        using x.arrow Dom_x Cod_x χ.natural_transformation_axioms
        by (intro J_C.arr_eqI, auto)
    qed

    lemma cone_determines_arrow:
    assumes "J_C.ide d" and "cone J C (J_C.Map d) a χ"
    shows "arrow_from_functor C J_C.comp map a d
             (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) χ)"
    and "J_C.Map (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) χ) = χ"
    proof -
       interpret χ: cone J C ‹J_C.Map d a χ using assms(2) by auto
       let ?x = "J_C.MkArr χ.A.map (J_C.Map d) χ"
       interpret x: arrow_from_functor C J_C.comp map a d ?x
       proof
         have "«J_C.MkArr χ.A.map (J_C.Map d) χ :
                  J_C.MkIde χ.A.map [J,C] J_C.MkIde (J_C.Map d)»"
           using χ.natural_transformation_axioms by auto
         moreover have "J_C.MkIde χ.A.map = map a"
           using χ.A.value_is_ide map_def χ.A.map_def C.ide_char
           by (metis (no_types, lifting) J_C.dom_MkArr preserves_arr preserves_dom)
         moreover have "J_C.MkIde (J_C.Map d) = d"
           using assms ide_determines_diagram(2) by simp
         ultimately show "C.ide a  «J_C.MkArr χ.A.map (J_C.Map d) χ : map a [J,C] d»"
           using χ.A.value_is_ide by simp
       qed
       show "arrow_from_functor C J_C.comp map a d ?x" ..
       show "J_C.Map (J_C.MkArr (constant_functor.map J C a) (J_C.Map d) χ) = χ"
         by (simp add: χ.natural_transformation_axioms)
    qed

    text‹
      Transforming a cone by composing at the apex with an arrow @{term g} corresponds,
      via the preceding bijections, to composition in [J, C]› with the image of @{term g}
      under the diagonal functor.
›

    lemma cones_map_is_composition:
    assumes "«g : a'  a»" and "cone J C D a χ"
    shows "J_C.MkArr (constant_functor.map J C a') D (diagram.cones_map J C D g χ)
             = J_C.MkArr (constant_functor.map J C a) D χ [J,C] map g"
    proof -
      interpret A: constant_transformation J C a
        using assms(1) by (unfold_locales, auto)
      interpret χ: cone J C D a χ using assms(2) by auto
      have cone_χ: "cone J C D a χ" ..
      interpret A': constant_transformation J C a'
        using assms(1) by (unfold_locales, auto)
      let ?χ' = "χ.D.cones_map g χ"
      interpret χ': cone J C D a' ?χ'
        using assms(1) cone_χ χ.D.cones_map_mapsto by blast
      let ?x = "J_C.MkArr χ.A.map D χ"
      let ?x' = "J_C.MkArr χ'.A.map D ?χ'"
      show "?x' = J_C.comp ?x (map g)"
      proof (intro J_C.arr_eqI)
        have x: "J_C.arr ?x"
          using χ.natural_transformation_axioms J_C.arr_char [of ?x] by simp
        show x': "J_C.arr ?x'"
          using χ'.natural_transformation_axioms J_C.arr_char [of ?x'] by simp
        have 3: "«?x : map a [J,C] J_C.MkIde D»"
        proof -
          have 1: "map a = J_C.MkIde A.map"
            using χ.ide_apex A.equals_dom_if_value_is_ide A.equals_cod_if_value_is_ide map_def
            by auto
          have "J_C.arr ?x" using x by blast
          moreover have "J_C.dom ?x = map a"
            using x J_C.dom_char 1 x χ.ide_apex A.equals_dom_if_value_is_ide χ.D.functor_axioms
                    J_C.ide_char
            by auto
          moreover have "J_C.cod ?x = J_C.MkIde D" using x J_C.cod_char by auto
          ultimately show ?thesis by fast
        qed
        have 4: "«?x' : map a' [J,C] J_C.MkIde D»"
        proof -
          have 1: "map a' = J_C.MkIde A'.map"
            using χ'.ide_apex A'.equals_dom_if_value_is_ide A'.equals_cod_if_value_is_ide map_def
            by auto
          have "J_C.arr ?x'" using x' by blast
          moreover have "J_C.dom ?x' = map a'"
            using x' J_C.dom_char 1 x' χ'.ide_apex A'.equals_dom_if_value_is_ide χ.D.functor_axioms
                    J_C.ide_char
            by force
          moreover have "J_C.cod ?x' = J_C.MkIde D" using x' J_C.cod_char by auto
          ultimately show ?thesis by fast
        qed
        have seq_xg: "J_C.seq ?x (map g)"
          using assms(1) 3 preserves_hom [of g] by (intro J_C.seqI', auto)
        show 2: "J_C.seq ?x (map g)"
          using seq_xg J_C.seqI' by blast
        show "J_C.Dom ?x' = J_C.Dom (?x [J,C] map g)"
        proof -
          have "J_C.Dom ?x' = J_C.Dom (J_C.dom ?x')"
            using x' J_C.Dom_dom by simp
          also have "... = J_C.Dom (map a')"
            using 4 by force
          also have "... = J_C.Dom (J_C.dom (?x [J,C] map g))"
            using assms(1) 2 by auto
          also have "... = J_C.Dom (?x [J,C] map g)"
            using seq_xg J_C.Dom_dom J_C.seqI' by blast
          finally show ?thesis by auto
        qed
        show "J_C.Cod ?x' = J_C.Cod (?x [J,C] map g)"
        proof -
          have "J_C.Cod ?x' = J_C.Cod (J_C.cod ?x')"
            using x' J_C.Cod_cod by simp
          also have "... = J_C.Cod (J_C.MkIde D)"
            using 4 by force
          also have "... = J_C.Cod (J_C.cod (?x [J,C] map g))"
            using 2 3 J_C.cod_comp J_C.in_homE by metis
          also have "... = J_C.Cod (?x [J,C] map g)"
            using seq_xg J_C.Cod_cod J_C.seqI' by blast
          finally show ?thesis by auto
        qed
        show "J_C.Map ?x' = J_C.Map (?x [J,C] map g)"
        proof -
          interpret g: constant_transformation J C g
            apply unfold_locales using assms(1) by auto
          interpret χog: vertical_composite J C A'.map χ.A.map D g.map χ
            using assms(1) C.comp_arr_dom C.comp_cod_arr A'.is_extensional g.is_extensional
            apply (unfold_locales, auto)
            by (elim J.seqE, auto)
          have "J_C.Map (?x [J,C] map g) = χog.map"
            using assms(1) 2 J_C.comp_char map_def by auto
          also have "... = J_C.Map ?x'"
            using x' χog.map_def J_C.arr_char [of ?x'] natural_transformation.is_extensional
                  assms(1) cone_χ χog.map_simp_2
            by fastforce
          finally show ?thesis by auto
        qed
      qed
    qed

    text‹
      Coextension along an arrow from a functor is equivalent to a transformation of cones.
›

    lemma coextension_iff_cones_map:
    assumes x: "arrow_from_functor C J_C.comp map a d x"
    and g: "«g : a'  a»"
    and x': "«x' : map a' [J,C] d»"
    shows "arrow_from_functor.is_coext C J_C.comp map a x a' x' g
               J_C.Map x' = diagram.cones_map J C (J_C.Map d) g (J_C.Map x)"
    proof -
      interpret x: arrow_from_functor C J_C.comp map a d x
        using assms by auto
      interpret A': constant_functor J C a'
        using assms(2) by (unfold_locales, auto)
      have x': "arrow_from_functor C J_C.comp map a' d x'"
        using A'.value_is_ide assms(3) by (unfold_locales, blast)
      have d: "J_C.ide d" using J_C.ide_cod x.arrow by blast
      let ?D = "J_C.Map d"
      let  = "J_C.Map x"
      let ?χ' = "J_C.Map x'"
      interpret D: diagram J C ?D
        using ide_determines_diagram J_C.ide_cod x.arrow by blast
      interpret χ: cone J C ?D a 
        using assms(1) d arrow_determines_cone by simp
      interpret γ: constant_transformation J C g
        using g χ.ide_apex by (unfold_locales, auto)
      interpret χog: vertical_composite J C A'.map χ.A.map ?D γ.map 
        using g C.comp_arr_dom C.comp_cod_arr γ.is_extensional by (unfold_locales, auto)
      show ?thesis
      proof
        assume 0: "x.is_coext a' x' g"
        show "?χ' = D.cones_map g "
        proof -
          have 1: "x' = x [J,C] map g"
            using 0 x.is_coext_def by blast
          hence "?χ' = J_C.Map x'"
            using 0 x.is_coext_def by fast
          moreover have "... = D.cones_map g "
          proof -
            have "J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)) =
                  x [J,C] map g"
              using d g cones_map_is_composition arrow_determines_cone(2) χ.cone_axioms
                    x.arrow_from_functor_axioms
              by auto
            hence f1: "J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)) = x'"
              by (metis 1)
            have "J_C.arr (J_C.MkArr A'.map (J_C.Map d) (D.cones_map g (J_C.Map x)))"
              using 1 d g cones_map_is_composition preserves_arr arrow_determines_cone(2)
                    χ.cone_axioms x.arrow_from_functor_axioms assms(3)
              by auto
            thus ?thesis
              using f1 by auto
          qed
          ultimately show ?thesis by blast
        qed
        next
        assume X': "?χ' = D.cones_map g "
        show "x.is_coext a' x' g"
        proof -
          have 4: "J_C.seq x (map g)"
            using g x.arrow mem_Collect_eq preserves_arr preserves_cod
            by (elim C.in_homE, auto)
          hence 1: "x [J,C] map g =
                   J_C.MkArr (J_C.Dom (map g)) (J_C.Cod x)
                             (vertical_composite.map J C (J_C.Map (map g)) )"
            using J_C.comp_char [of x "map g"] by simp
          have 2: "vertical_composite.map J C (J_C.Map (map g))  = χog.map"
            by (simp add: map_def γ.value_is_arr γ.natural_transformation_axioms)
          have 3: "... = D.cones_map g "
            using g χog.map_simp_2 χ.cone_axioms χog.is_extensional by auto
          have "J_C.MkArr A'.map ?D ?χ' = J_C.comp x (map g)"
          proof -
            have f1: "A'.map = J_C.Dom (map g)"
              using γ.natural_transformation_axioms map_def g by auto
            have "J_C.Map d = J_C.Cod x"
              using x.arrow by auto
            thus ?thesis using f1 X' 1 2 3 by argo
          qed
          moreover have "J_C.MkArr A'.map ?D ?χ' = x'"
            using d x' arrow_determines_cone by blast
          ultimately show ?thesis
            using g x.is_coext_def by simp
        qed
      qed
    qed

  end

  locale right_adjoint_to_diagonal_functor =
    C: category C +
    J: category J +
    J_C: functor_category J C +
    Δ: diagonal_functor J C +
    "functor" J_C.comp C G +
    Adj: meta_adjunction J_C.comp C Δ.map G φ ψ
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and G :: "('j, 'c) functor_category.arr  'c"
  and φ :: "'c  ('j, 'c) functor_category.arr  'c"
  and ψ :: "('j, 'c) functor_category.arr  'c  ('j, 'c) functor_category.arr" +
  assumes adjoint: "adjoint_functors J_C.comp C Δ.map G"
  begin

    interpretation Adj: adjunction J_C.comp C replete_setcat.comp Adj.φC Adj.φD Δ.map G
                          φ ψ Adj.η Adj.ε Adj.Φ Adj.Ψ
      using Adj.induces_adjunction by simp

    text‹
      A right adjoint @{term G} to a diagonal functor maps each object @{term d} of
      [J, C]› (corresponding to a diagram @{term D} of shape @{term J} in @{term C}
      to an object of @{term C}.  This object is the limit object, and the component at @{term d}
      of the counit of the adjunction determines the limit cone.
›

    lemma gives_limit_cones:
    assumes "diagram J C D"
    shows "limit_cone J C D (G (J_C.MkIde D)) (J_C.Map (Adj.ε (J_C.MkIde D)))"
    proof -
      interpret D: diagram J C D using assms by auto
      let ?d = "J_C.MkIde D"
      let ?a = "G ?d"
      let ?x = "Adj.ε ?d"
      let  = "J_C.Map ?x"
      have "diagram J C D" ..
      hence 1: "J_C.ide ?d" using Δ.diagram_determines_ide by auto
      hence 2: "J_C.Map (J_C.MkIde D) = D"
        using assms 1 J_C.in_homE Δ.diagram_determines_ide(2) by simp
      interpret x: terminal_arrow_from_functor C J_C.comp Δ.map ?a ?d ?x
        apply unfold_locales
         apply (metis (no_types, lifting) "1" preserves_ide Adj.ε_in_terms_of_ψ
                Adj.εo_def Adj.εo_in_hom)
        by (metis 1 Adj.has_terminal_arrows_from_functor(1)
                  terminal_arrow_from_functor.is_terminal)
      have 3: "arrow_from_functor C J_C.comp Δ.map ?a ?d ?x" ..
      interpret χ: cone J C D ?a 
        using 1 2 3 Δ.arrow_determines_cone [of ?d] by auto
      have cone_χ: "D.cone ?a " ..
      interpret χ: limit_cone J C D ?a 
      proof
        fix a' χ'
        assume cone_χ': "D.cone a' χ'"
        interpret χ': cone J C D a' χ' using cone_χ' by auto
        let ?x' = "J_C.MkArr χ'.A.map D χ'"
        interpret x': arrow_from_functor C J_C.comp Δ.map a' ?d ?x'
          using 1 2 by (metis Δ.cone_determines_arrow(1) cone_χ')
        have "arrow_from_functor C J_C.comp Δ.map a' ?d ?x'" ..
        hence 4: "∃!g. x.is_coext a' ?x' g"
          using x.is_terminal by simp
        have 5: "g. «g : a' C ?a»  x.is_coext a' ?x' g  D.cones_map g  = χ'"
        proof -
          fix g
          assume g: "«g : a' C ?a»"
          show "x.is_coext a' ?x' g  D.cones_map g  = χ'"
          proof -
            have "«?x' : Δ.map a' [J,C] ?d»"
              using x'.arrow by simp
            thus ?thesis
              using 1 2 3 g Δ.coextension_iff_cones_map Δ.cone_determines_arrow(2)
                    cone_χ'
              by force
          qed
        qed
        have 6: "g. x.is_coext a' ?x' g  «g : a' C ?a»"
          using x.is_coext_def by simp
        show "∃!g. «g : a' C ?a»  D.cones_map g  = χ'"
        proof -
          have "g. «g : a' C ?a»  D.cones_map g  = χ'"
            using 4 5 6 by meson
          thus ?thesis
            using 4 5 6 by blast
        qed
      qed
      show "D.limit_cone ?a " ..
    qed

    corollary gives_limits:
    assumes "diagram J C D"
    shows "diagram.has_as_limit J C D (G (J_C.MkIde D))"
      using assms gives_limit_cones by fastforce

  end

  lemma (in category) has_limits_iff_left_adjoint_diagonal:
  assumes "category J"
  shows "has_limits_of_shape J 
           left_adjoint_functor C (functor_category.comp J C) (diagonal_functor.map J C)"
  proof -
    interpret J: category J using assms by auto
    interpret J_C: functor_category J C ..
    interpret Δ: diagonal_functor J C ..
    show ?thesis
    proof
      assume A: "left_adjoint_functor C J_C.comp Δ.map"
      interpret Δ: left_adjoint_functor C J_C.comp Δ.map using A by auto
      interpret Adj: meta_adjunction J_C.comp C Δ.map Δ.G Δ.φ Δ.ψ
        using Δ.induces_meta_adjunction by auto
      have "meta_adjunction J_C.comp C Δ.map Δ.G Δ.φ Δ.ψ" ..
      hence 1: "adjoint_functors J_C.comp C Δ.map Δ.G"
        using adjoint_functors_def by blast
      interpret G: right_adjoint_to_diagonal_functor J C Δ.G Δ.φ Δ.ψ
        using 1 by (unfold_locales, auto)
      have "D. diagram J C D  a. diagram.has_as_limit J C D a"
        using A G.gives_limits by blast
      hence "D. diagram J C D  a χ. limit_cone J C D a χ"
        by metis
      thus "has_limits_of_shape J" using has_limits_of_shape_def by blast
      next
      text‹
        If @{term "has_limits J"}, then every diagram @{term D} from @{term J} to
        @{term[source=true] C} has a limit cone.
        This means that, for every object @{term d} of the functor category
        [J, C]›, there exists an object @{term a} of @{term C} and a terminal arrow from
        Δ a› to @{term d} in [J, C]›.  The terminal arrow is given by the
        limit cone.
›
      assume A: "has_limits_of_shape J"
      show "left_adjoint_functor C J_C.comp Δ.map"
      proof
        fix d
        assume D: "J_C.ide d"
        interpret D: diagram J C ‹J_C.Map d
          using D Δ.ide_determines_diagram by auto
        let ?D = "J_C.Map d"
        have "diagram J C (J_C.Map d)" ..
        from this obtain a χ where limit: "limit_cone J C ?D a χ"
          using A has_limits_of_shape_def by blast
        interpret A: constant_functor J C a
          using limit by (simp add: Limit.cone_def limit_cone_def)
        interpret χ: limit_cone J C ?D a χ using limit by simp
        have cone_χ: "cone J C ?D a χ" ..
        let ?x = "J_C.MkArr A.map ?D χ"
        interpret x: arrow_from_functor C J_C.comp Δ.map a d ?x
          using D cone_χ Δ.cone_determines_arrow by auto
        have "terminal_arrow_from_functor C J_C.comp Δ.map a d ?x"
        proof
          show "a' x'. arrow_from_functor C J_C.comp Δ.map a' d x'  ∃!g. x.is_coext a' x' g"
          proof -
            fix a' x'
            assume x': "arrow_from_functor C J_C.comp Δ.map a' d x'"
            interpret x': arrow_from_functor C J_C.comp Δ.map a' d x' using x' by auto
            interpret A': constant_functor J C a'
              by (unfold_locales, simp add: x'.arrow)
            let ?χ' = "J_C.Map x'"
            interpret χ': cone J C ?D a' ?χ'
              using D x' Δ.arrow_determines_cone by auto
            have cone_χ': "cone J C ?D a' ?χ'" ..
            let ?g = "χ.induced_arrow a' ?χ'"
            show "∃!g. x.is_coext a' x' g"
            proof
              show "x.is_coext a' x' ?g"
              proof (unfold x.is_coext_def)
                have 1: "«?g : a'  a»  D.cones_map ?g χ = ?χ'"
                  using χ.induced_arrow_def χ.is_universal cone_χ'
                        theI' [of "λf. «f : a'  a»  D.cones_map f χ = ?χ'"]
                  by presburger
                hence 2: "x' = ?x [J,C] Δ.map ?g"
                proof -
                  have "x' = J_C.MkArr A'.map ?D ?χ'"
                    using D Δ.arrow_determines_cone(2) x'.arrow_from_functor_axioms by auto
                  thus ?thesis
                    using 1 cone_χ Δ.cones_map_is_composition [of ?g a' a ?D χ] by simp
                qed
                show "«?g : a'  a»  x' = ?x [J,C] Δ.map ?g"
                  using 1 2 by auto
              qed
              next
              fix g
              assume X: "x.is_coext a' x' g"
              show "g = ?g"
              proof -
                have "«g : a'  a»  D.cones_map g χ = ?χ'"
                proof
                  show G: "«g : a'  a»" using X x.is_coext_def by blast
                  show "D.cones_map g χ = ?χ'"
                  proof -
                    have "?χ' = J_C.Map (?x [J,C] Δ.map g)"
                      using X x.is_coext_def [of a' x' g] by fast
                    also have "... = D.cones_map g χ"
                    proof -
                      interpret map_g: constant_transformation J C g
                        using G by (unfold_locales, auto)
                      interpret χ': vertical_composite J C
                                      map_g.F.map A.map ‹χ.Φ.Ya.Cop_S.Map d
                                      map_g.map χ
                      proof (intro_locales)
                        have "map_g.G.map = A.map"
                          using G by blast
                        thus "natural_transformation_axioms J (⋅) map_g.F.map A.map map_g.map"
                          using map_g.natural_transformation_axioms
                          by (simp add: natural_transformation_def)
                      qed
                      have "J_C.Map (?x [J,C] Δ.map g) = vertical_composite.map J C map_g.map χ"
                      proof -
                        have "J_C.seq ?x (Δ.map g)"
                          using G x.arrow by auto
                        thus ?thesis
                          using G Δ.map_def J_C.Map_comp' [of ?x "Δ.map g"] by auto
                      qed
                      also have "... = D.cones_map g χ"
                        using G cone_χ χ'.map_def map_g.map_def χ.is_natural_2 χ'.map_simp_2
                        by auto
                      finally show ?thesis by blast
                    qed
                    finally show ?thesis by auto
                  qed
                qed
                thus ?thesis
                  using cone_χ' χ.is_universal χ.induced_arrow_def
                        theI_unique [of "λg. «g : a'  a»  D.cones_map g χ = ?χ'" g]
                  by presburger
              qed
            qed
          qed
        qed
        thus "a x. terminal_arrow_from_functor C J_C.comp Δ.map a d x" by auto
      qed
    qed
  qed

  section "Right Adjoint Functors Preserve Limits"

  context right_adjoint_functor
  begin

    lemma preserves_limits:
    fixes J :: "'j comp"
    assumes "diagram J C E" and "diagram.has_as_limit J C E a"
    shows "diagram.has_as_limit J D (G o E) (G a)"
    proof -
      text‹
        From the assumption that @{term E} has a limit, obtain a limit cone @{term χ}.
›
      interpret J: category J using assms(1) diagram_def by auto
      interpret E: diagram J C E using assms(1) by auto
      from assms(2) obtain χ where χ: "limit_cone J C E a χ" by auto
      interpret χ: limit_cone J C E a χ using χ by auto
      have a: "C.ide a" using χ.ide_apex by auto
      text‹
        Form the @{term E}-image GE› of the diagram @{term E}.
›
      interpret GE: composite_functor J C D E G ..
      interpret GE: diagram J D GE.map ..
      text‹Let Gχ› be the @{term G}-image of the cone @{term χ},
             and note that it is a cone over GE›.›
      let ?Gχ = "G o χ"
      interpret: cone J D GE.map G a ?Gχ
        using χ.cone_axioms preserves_cones by blast
      text‹
        Claim that Gχ› is a limit cone for diagram GE›.
›
      interpret: limit_cone J D GE.map G a ?Gχ
      proof
        text ‹
          Let @{term κ} be an arbitrary cone over GE›.
›
        fix b κ
        assume κ: "GE.cone b κ"
        interpret κ: cone J D GE.map b κ using κ by auto
        interpret Fb: constant_functor J C ‹F b
          apply unfold_locales
          by (meson F_is_functor κ.ide_apex functor.preserves_ide)
        interpret Adj: meta_adjunction C D F G φ ψ
          using induces_meta_adjunction by auto
        interpret Adj: adjunction C D replete_setcat.comp
                         Adj.φC Adj.φD F G φ ψ Adj.η Adj.ε Adj.Φ Adj.Ψ
          using Adj.induces_adjunction by simp
        text‹
          For each arrow @{term j} of @{term J}, let @{term "χ' j"} be defined to be
          the adjunct of @{term "χ j"}.  We claim that @{term χ'} is a cone over @{term E}.
›
        let ?χ' = "λj. if J.arr j then Adj.ε (C.cod (E j)) C F (κ j) else C.null"
        have cone_χ': "E.cone (F b) ?χ'"
        proof
          show "j. ¬J.arr j  ?χ' j = C.null" by simp
          fix j
          assume j: "J.arr j"
          show "C.dom (?χ' j) = Fb.map (J.dom j)" using j ψ_in_hom by simp
          show "C.cod (?χ' j) = E (J.cod j)" using j ψ_in_hom by simp
          show "E j C ?χ' (J.dom j) = ?χ' j"
          proof -
            have "E j C ?χ' (J.dom j) = (E j C Adj.ε (E (J.dom j))) C F (κ (J.dom j))"
              using j C.comp_assoc by simp
            also have "... = Adj.ε (E (J.cod j)) C F (κ j)"
            proof -
              have "(E j C Adj.ε (E (J.dom j))) C F (κ (J.dom j))
                       = (Adj.ε (C.cod (E j)) C Adj.FG.map (E j)) C F (κ (J.dom j))"
                using j Adj.ε.naturality [of "E j"] by fastforce
              also have "... = Adj.ε (C.cod (E j)) C Adj.FG.map (E j) C F (κ (J.dom j))"
                using C.comp_assoc by simp
              also have "... = Adj.ε (E (J.cod j)) C F (κ j)"
              proof -
                have "Adj.FG.map (E j) C F (κ (J.dom j)) = F (GE.map j D κ (J.dom j))"
                  using j by simp
                hence "Adj.FG.map (E j) C F (κ (J.dom j)) = F (κ j)"
                  using j κ.is_natural_1 by metis
                thus ?thesis using j by simp
              qed
              finally show ?thesis by auto
            qed
            also have "... = ?χ' j"
              using j by simp
            finally show ?thesis by auto
          qed
          show "?χ' (J.cod j) C Fb.map j = ?χ' j"
          proof -
            have "?χ' (J.cod j) C Fb.map j = Adj.ε (E (J.cod j)) C F (κ (J.cod j))"
              using j Fb.value_is_ide Adj.ε.preserves_hom C.comp_arr_dom [of "F (κ (J.cod j))"]
                    C.comp_assoc
              by simp
            also have "... = Adj.ε (E (J.cod j)) C F (κ j)"
              using j κ.is_natural_1 κ.is_natural_2 Adj.ε.naturality J.arr_cod_iff_arr
              by (metis J.cod_cod κ.A.map_simp)
            also have "... = ?χ' j" using j by simp
            finally show ?thesis by auto
          qed
        qed
        text‹
          Using the universal property of the limit cone @{term χ}, obtain the unique arrow
          @{term f} that transforms @{term χ} into @{term χ'}.
›
        from this χ.is_universal [of "F b" ?χ'] obtain f
          where f: "«f : F b C a»  E.cones_map f χ = ?χ'"
          by auto
        text‹
          Let @{term g} be the adjunct of @{term f}, and show that @{term g} transforms
          @{term } into @{term κ}.
›
        let ?g = "G f D Adj.η b"
        have 1: "«?g : b D G a»" using f κ.ide_apex by fastforce
        moreover have "GE.cones_map ?g ?Gχ = κ"
        proof
          fix j
          have "¬J.arr j  GE.cones_map ?g ?Gχ j = κ j"
            using 1 Gχ.cone_axioms κ.is_extensional by auto
          moreover have "J.arr j  GE.cones_map ?g ?Gχ j = κ j"
          proof -
            fix j
            assume j: "J.arr j"
            have "GE.cones_map ?g ?Gχ j = G (χ j) D ?g"
              using j 1 Gχ.cone_axioms mem_Collect_eq restrict_apply by auto
            also have "... = G (χ j C f) D Adj.η b"
              using j f χ.preserves_hom [of j "J.dom j" "J.cod j"] D.comp_assoc by fastforce
            also have "... = G (E.cones_map f χ j) D Adj.η b"
            proof -
              have "χ j C f = Adj.ε (C.cod (E j)) C F (κ j)"
              proof -
                have "E.cone (C.cod f) χ"
                  using f χ.cone_axioms by blast
                hence "χ j C f = E.cones_map f χ j"
                  using χ.is_extensional by simp
                also have "... = Adj.ε (C.cod (E j)) C F (κ j)"
                  using j f by simp
                finally show ?thesis by blast
              qed
              thus ?thesis
                using f mem_Collect_eq restrict_apply Adj.F.is_extensional by simp
            qed
            also have "... = (G (Adj.ε (C.cod (E j))) D Adj.η (D.cod (GE.map j))) D κ j"
              using j f Adj.η.naturality [of "κ j"] D.comp_assoc by auto
            also have "... = D.cod (κ j) D κ j"
              using j Adj.ηε.triangle_G Adj.ε_in_terms_of_ψ Adj.εo_def
                      Adj.η_in_terms_of_φ Adj.ηo_def Adj.unit_counit_G
              by fastforce
            also have "... = κ j"
              using j D.comp_cod_arr by simp
            finally show "GE.cones_map ?g ?Gχ j = κ j" by metis
          qed
          ultimately show "GE.cones_map ?g ?Gχ j = κ j" by auto
        qed
        ultimately have "«?g : b D G a»  GE.cones_map ?g ?Gχ = κ" by auto
        text‹
          It remains to be shown that @{term g} is the unique such arrow.
          Given any @{term g'} that transforms @{term } into @{term κ},
          its adjunct transforms @{term χ} into @{term χ'}.
          The adjunct of @{term g'} is therefore equal to @{term f},
          which implies @{term g'} = @{term g}.
›
        moreover have "g'. «g' : b D G a»  GE.cones_map g' ?Gχ = κ  g' = ?g"
        proof -
          fix g'
          assume g': "«g' : b D G a»  GE.cones_map g' ?Gχ = κ"
          have 1: "«ψ a g' : F b C a»"
            using g' a ψ_in_hom by simp
          have 2: "E.cones_map (ψ a g') χ = ?χ'"
          proof
            fix j
            have "¬J.arr j  E.cones_map (ψ a g') χ j = ?χ' j"
              using 1 χ.cone_axioms by auto
            moreover have "J.arr j  E.cones_map (ψ a g') χ j = ?χ' j"
            proof -
              fix j
              assume j: "J.arr j"
              have "E.cones_map (ψ a g') χ j = χ j C ψ a g'"
                using 1 χ.cone_axioms χ.is_extensional by auto
              also have "... = (χ j C Adj.ε a) C F g'"
                using j a g' Adj.ψ_in_terms_of_ε C.comp_assoc Adj.ε_def by auto
              also have "... = (Adj.ε (C.cod (E j)) C F (G (χ j))) C F g'"
                using j a g' Adj.ε.naturality [of "χ j"] by simp
              also have "... = Adj.ε (C.cod (E j)) C F (κ j)"
                using j a g' Gχ.cone_axioms C.comp_assoc by auto
              finally show "E.cones_map (ψ a g') χ j = ?χ' j" by (simp add: j)
            qed
            ultimately show "E.cones_map (ψ a g') χ j = ?χ' j" by auto
          qed
          have a g' = f"
          proof -
            have "∃!f. «f : F b C a»  E.cones_map f χ = ?χ'"
              using cone_χ' χ.is_universal by simp
            moreover have "«ψ a g' : F b C a»  E.cones_map (ψ a g') χ = ?χ'"
              using 1 2 by simp
            ultimately show ?thesis
              using ex1E [of "λf. «f : F b C a»  E.cones_map f χ = ?χ'" a g' = f"]
              using 1 2 Adj.ε.is_extensional C.comp_null(2) C.ex_un_null χ.cone_axioms f
                    mem_Collect_eq restrict_apply
              by blast
          qed
          hence b (ψ a g') = φ b f" by auto
          hence "g' = φ b f" using χ.ide_apex g' by (simp add: φ_ψ)
          moreover have "?g = φ b f" using f Adj.φ_in_terms_of_η κ.ide_apex Adj.η_def by auto
          ultimately show "g' = ?g" by argo
        qed
        ultimately show "∃!g. «g : b D G a»  GE.cones_map g ?Gχ = κ" by blast
      qed
      have "GE.limit_cone (G a) ?Gχ" ..
      thus ?thesis by auto
    qed

  end

  section "Special Kinds of Limits"

  subsection "Terminal Objects"

  text‹
   An object of a category @{term C} is a terminal object if and only if it is a limit of the
   empty diagram in @{term C}.
›

  locale empty_diagram =
    diagram J C D
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'j  'c" +
  assumes is_empty: "¬J.arr j"
  begin

    lemma has_as_limit_iff_terminal:
    shows "has_as_limit a  C.terminal a"
    proof
      assume a: "has_as_limit a"
      show "C.terminal a"
      proof
        have "χ. limit_cone a χ" using a by auto
        from this obtain χ where χ: "limit_cone a χ" by blast
        interpret χ: limit_cone J C D a χ using χ by auto
        have cone_χ: "cone a χ" ..
        show "C.ide a" using χ.ide_apex by auto
        have 1: "χ = (λj. C.null)" using is_empty χ.is_extensional by auto
        show "a'. C.ide a'  ∃!f. «f : a'  a»"
        proof -
          fix a'
          assume a': "C.ide a'"
          interpret A': constant_functor J C a'
            apply unfold_locales using a' by auto
          let ?χ' = "λj. C.null"
          have cone_χ': "cone a' ?χ'"
            using a' is_empty apply unfold_locales by auto
          hence "∃!f. «f : a'  a»  cones_map f χ = ?χ'"
            using χ.is_universal by force
          moreover have "f. «f : a'  a»  cones_map f χ = ?χ'"
            using 1 cone_χ by auto
          ultimately show "∃!f. «f : a'  a»" by blast
        qed
      qed
      next
      assume a: "C.terminal a"
      show "has_as_limit a"
      proof -
        let  = "λj. C.null"
        have "C.ide a" using a C.terminal_def by simp
        interpret A: constant_functor J C a
          apply unfold_locales using ‹C.ide a by simp
        interpret χ: cone J C D a 
          using ‹C.ide a is_empty by (unfold_locales, auto)
        have cone_χ: "cone a " .. 
        have 1: "a' χ'. cone a' χ'  χ' = (λj. C.null)"
        proof -
          fix a' χ'
          assume χ': "cone a' χ'"
          interpret χ': cone J C D a' χ' using χ' by auto
          show "χ' = (λj. C.null)"
            using is_empty χ'.is_extensional by metis
        qed
        have "limit_cone a "
        proof
          fix a' χ'
          assume χ': "cone a' χ'"
          have 2: "χ' = (λj. C.null)" using 1 χ' by simp
          interpret χ': cone J C D a' χ' using χ' by auto
          have "∃!f. «f : a'  a»" using a C.terminal_def χ'.ide_apex by simp
          moreover have "f. «f : a'  a»  cones_map f  = χ'"
           using 1 2 cones_map_mapsto cone_χ χ'.cone_axioms mem_Collect_eq by blast
          ultimately show "∃!f. «f : a'  a»  cones_map f (λj. C.null) = χ'"
            by blast
        qed
        thus ?thesis by auto
      qed
    qed

  end

  subsection "Products"

  text‹
    A \emph{product} in a category @{term C} is a limit of a discrete diagram in @{term C}.
›

  locale discrete_diagram =
    J: category J +
    diagram J C D
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'j  'c" +
  assumes is_discrete: "J.arr = J.ide"
  begin

    abbreviation mkCone
    where "mkCone F  (λj. if J.arr j then F j else C.null)"

    lemma cone_mkCone:
    assumes "C.ide a" and "j. J.arr j  «F j : a  D j»"
    shows "cone a (mkCone F)"
    proof -
      interpret A: constant_functor J C a
        apply unfold_locales using assms(1) by auto
      show "cone a (mkCone F)"
        using assms(2) is_discrete
        apply unfold_locales
            apply auto
         apply (metis C.in_homE C.comp_cod_arr)
        using C.comp_arr_ide by fastforce
    qed

    lemma mkCone_cone:
    assumes "cone a π"
    shows "mkCone π = π"
    proof -
      interpret π: cone J C D a π
        using assms by auto
      show "mkCone π = π" using π.is_extensional by auto
    qed

  end

  text‹
    The following locale defines a discrete diagram in a category @{term C},
    given an index set @{term I} and a function @{term D} mapping @{term I}
    to objects of @{term C}.  Here we obtain the diagram shape @{term J}
    using a discrete category construction that allows us to directly identify
    the objects of @{term J} with the elements of @{term I}, however this construction
    can only be applied in case the set @{term I} is not the universe of its
    element type.
›

  locale discrete_diagram_from_map =
    J: discrete_category I null +
    C: category C
  for I :: "'i set"
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'i  'c"
  and null :: 'i +
  assumes maps_to_ide: "i  I  C.ide (D i)"
  begin

    definition map
    where "map j  if J.arr j then D j else C.null"

  end

  sublocale discrete_diagram_from_map  discrete_diagram J.comp C map
    using map_def maps_to_ide J.arr_char J.Null_not_in_Obj J.null_char
    by (unfold_locales, auto)

  locale product_cone =
    J: category J +
    C: category C +
    D: discrete_diagram J C D +
    limit_cone J C D a π
  for J :: "'j comp"      (infixr "J" 55)
  and C :: "'c comp"      (infixr "" 55)
  and D :: "'j  'c"
  and a :: 'c
  and π :: "'j  'c"
  begin

    lemma is_cone:
    shows "D.cone a π" ..

    text‹
      The following versions of @{prop is_universal} and @{prop induced_arrowI}
      from the limit_cone› locale are specialized to the case in which the
      underlying diagram is a product diagram.
›

    lemma is_universal':
    assumes "C.ide b" and "j. J.arr j  «F j: b  D j»"
    shows "∃!f. «f : b  a»  (j. J.arr j  π j  f = F j)"
    proof -
      let  = "D.mkCone F"
      interpret B: constant_functor J C b
        apply unfold_locales using assms(1) by auto
      have cone_χ: "D.cone b "
        using assms D.is_discrete
        apply unfold_locales
            apply auto
         apply (meson C.comp_ide_arr C.ide_in_hom C.seqI' D.preserves_ide)
        using C.comp_arr_dom by blast
      interpret χ: cone J C D b  using cone_χ by auto
      have "∃!f. «f : b  a»  D.cones_map f π = "
        using cone_χ is_universal by force
      moreover have
           "f. «f : b  a»  D.cones_map f π =   (j. J.arr j  π j  f = F j)"
      proof -
        fix f
        assume f: "«f : b  a»"
        show "D.cones_map f π =   (j. J.arr j  π j  f = F j)"
        proof
          assume 1: "D.cones_map f π = "
          show "j. J.arr j  π j  f = F j"
          proof -
            have "j. J.arr j  π j  f = F j"
            proof -
              fix j
              assume j: "J.arr j"
              have "π j  f = D.cones_map f π j"
                using j f cone_axioms by force
              also have "... = F j" using j 1 by simp
              finally show "π j  f = F j" by auto
            qed
            thus ?thesis by auto
          qed
          next
          assume 1: "j. J.arr j  π j  f = F j"
          show "D.cones_map f π = "
            using 1 f is_cone χ.is_extensional D.is_discrete is_cone cone_χ by auto
        qed
      qed
      ultimately show ?thesis by blast
    qed

    abbreviation induced_arrow' :: "'c  ('j  'c)  'c"
    where "induced_arrow' b F  induced_arrow b (D.mkCone F)"

    lemma induced_arrowI':
    assumes "C.ide b" and "j. J.arr j  «F j : b  D j»"
    shows "j. J.arr j  π j  induced_arrow' b F = F j"
    proof -
      interpret B: constant_functor J C b
        apply unfold_locales using assms(1) by auto
      interpret χ: cone J C D b ‹D.mkCone F
        using assms D.cone_mkCone by blast
      have cone_χ: "D.cone b (D.mkCone F)" ..
      hence 1: "D.cones_map (induced_arrow' b F) π = D.mkCone F"
        using induced_arrowI by blast
      fix j
      assume j: "J.arr j"
      have "π j  induced_arrow' b F = D.cones_map (induced_arrow' b F) π j"
        using induced_arrowI(1) cone_χ is_cone is_extensional by force
      also have "... = F j"
        using j 1 by auto
      finally show "π j  induced_arrow' b F = F j"
        by auto
    qed

  end

  context discrete_diagram
  begin

    lemma product_coneI:
    assumes "limit_cone a π" 
    shows "product_cone J C D a π"
    proof -
      interpret L: limit_cone J C D a π
        using assms by auto
      show "product_cone J C D a π" ..
    qed

  end

  context category
  begin

    definition has_as_product
    where "has_as_product J D a  (π. product_cone J C D a π)"

    lemma product_is_ide:
    assumes "has_as_product J D a"
    shows "ide a"
    proof -
      obtain π where π: "product_cone J C D a π"
        using assms has_as_product_def by blast
      interpret π: product_cone J C D a π
        using π by auto
      show ?thesis using π.ide_apex by auto
    qed

    text‹
      A category has @{term I}-indexed products for an @{typ 'i}-set @{term I}
      if every @{term I}-indexed discrete diagram has a product.
      In order to reap the benefits of being able to directly identify the elements
      of a set I with the objects of discrete category it generates (thereby avoiding
      the use of coercion maps), it is necessary to assume that @{term "I  UNIV"}.
      If we want to assert that a category has products indexed by the universe of
      some type @{typ 'i}, we have to pass to a larger type, such as @{typ "'i option"}.
›

    definition has_products
    where "has_products (I :: 'i set) 
             I  UNIV 
             (J D. discrete_diagram J C D  Collect (partial_magma.arr J) = I
                       (a. has_as_product J D a))"

    lemma ex_productE:
    assumes "a. has_as_product J D a"
    obtains a π where "product_cone J C D a π"
      using assms has_as_product_def someI_ex [of "λa. has_as_product J D a"] by metis

    lemma has_products_if_has_limits:
    assumes "has_limits (undefined :: 'j)" and "I  (UNIV :: 'j set)"
    shows "has_products I"
    proof (unfold has_products_def, intro conjI allI impI)
      show "I  UNIV" by fact
      fix J D
      assume D: "discrete_diagram J C D  Collect (partial_magma.arr J) = I"
      interpret D: discrete_diagram J C D
        using D by simp
      have 1: "a. D.has_as_limit a"
        using assms D D.diagram_axioms D.J.category_axioms
        by (simp add: has_limits_of_shape_def has_limits_def)
      show "a. has_as_product J D a"
        using 1 has_as_product_def D.product_coneI by blast
    qed

    lemma has_finite_products_if_has_finite_limits:
    assumes "J :: 'j comp. (finite (Collect (partial_magma.arr J)))  has_limits_of_shape J"
    and "finite (I :: 'j set)" and "I  UNIV"
    shows "has_products I"
    proof (unfold has_products_def, intro conjI allI impI)
      show "I  UNIV" by fact
      fix J D
      assume D: "discrete_diagram J C D  Collect (partial_magma.arr J) = I"
      interpret D: discrete_diagram J C D
        using D by simp
      have 1: "a. D.has_as_limit a"
        using assms D has_limits_of_shape_def D.diagram_axioms by auto
      show "a. has_as_product J D a"
        using 1 has_as_product_def D.product_coneI by blast
    qed

    lemma has_products_preserved_by_bijection:
    assumes "has_products I" and "bij_betw φ I I'" and "I'  UNIV"
    shows "has_products I'"
    proof (unfold has_products_def, intro conjI allI impI)
      show "I'  UNIV" by fact
      show "J' D'. discrete_diagram J' C D'  Collect (partial_magma.arr J') = I'
                      a. has_as_product J' D' a"
      proof -
        fix J' D'
        assume 1: "discrete_diagram J' C D'  Collect (partial_magma.arr J') = I'"
        interpret J': category J'
          using 1 by (simp add: discrete_diagram_def)
        interpret D': discrete_diagram J' C D'
          using 1 by simp
        interpret J: discrete_category I SOME x. x  I
          using assms has_products_def [of I] someI_ex [of "λx. x  I"]
          by unfold_locales auto
        have 2: "Collect J.arr = I  Collect J'.arr = I'"
          using 1 by auto
        have φ: "bij_betw φ (Collect J.arr) (Collect J'.arr)"
          using 2 assms(2) by simp
        let  = "λj. if J.arr j then φ j else J'.null"
        let ?φ' = "λj'. if J'.arr j' then the_inv_into I φ j' else J.null"
        interpret φ: "functor" J.comp J' 
        proof -
          have "φ ` I = I'"
            using φ 2 bij_betw_def [of φ I I'] by simp
          hence "j. J.arr j  J'.arr ( j)"
            using 1 D'.is_discrete by auto
          thus "functor J.comp J' "
            using D'.is_discrete J.is_discrete J.seqE
            by unfold_locales auto
        qed
        interpret φ': "functor" J' J.comp ?φ'
        proof -
          have "the_inv_into I φ ` I' = I"
            using assms(2) φ bij_betw_the_inv_into bij_betw_imp_surj_on by metis
          hence "j'. J'.arr j'  J.arr (?φ' j')"
            using 2 D'.is_discrete J.is_discrete by auto
          thus "functor J' J.comp ?φ'"
            using D'.is_discrete J.is_discrete J'.seqE
            by unfold_locales auto
        qed
        let ?D = "λi. D' (φ i)"
        interpret D: discrete_diagram_from_map I C ?D SOME j. j  I
          using assms 1 D'.is_discrete bij_betw_imp_surj_on φ.preserves_ide
          by unfold_locales auto
        obtain a where a: "has_as_product J.comp D.map a"
          using assms D.discrete_diagram_axioms has_products_def [of I] by auto
        obtain π where π: "product_cone J.comp C D.map a π"
          using a has_as_product_def by blast
        interpret π: product_cone J.comp C D.map a π
          using π by simp
        let ?π' = "π o ?φ'"
        interpret A: constant_functor J' C a
          using π.ide_apex by unfold_locales simp
        interpret π': natural_transformation J' C A.map D' ?π'
        proof -
          have "π.A.map  ?φ' = A.map"
            using φ A.map_def φ'.preserves_arr π.A.is_extensional J.not_arr_null by auto
          moreover have "D.map  ?φ' = D'"
          proof
            fix j'
            have "J'.arr j'  (D.map  ?φ') j' = D' j'"
            proof -
              assume 2: "J'.arr j'"
              have 3: "inj_on φ I"
                using assms(2) bij_betw_imp_inj_on by auto
              have "φ ` I = I'"
                by (metis (no_types) assms(2) bij_betw_imp_surj_on)
              hence "φ ` I = Collect J'.arr"
                using 1 by force
              thus ?thesis
                using 2 3 D.map_def φ'.preserves_arr f_the_inv_into_f by fastforce
            qed
            moreover have "¬ J'.arr j'  (D.map  ?φ') j' = D' j'"
              using D.is_extensional D'.is_extensional
              by (simp add: J.Null_not_in_Obj J.null_char)
            ultimately show "(D.map  ?φ') j' = D' j'" by blast
          qed
          ultimately show "natural_transformation J' C A.map D' ?π'"
            using π.natural_transformation_axioms φ'.natural_transformation_axioms
                  horizontal_composite [of J' J.comp ?φ' ?φ' ?φ' C π.A.map D.map π]
            by simp
        qed
        interpret π': cone J' C D' a ?π' ..
        interpret π': product_cone J' C D' a ?π'
        proof
          fix a' χ'
          assume χ': "D'.cone a' χ'"
          interpret χ': cone J' C D' a' χ'
            using χ' by simp
          show "∃!f. «f : a'  a»  D'.cones_map f (π  ?φ') = χ'"
          proof -
            let  = "χ' o "
            interpret A': constant_functor J.comp C a'
              using χ'.ide_apex by unfold_locales simp
            interpret χ: natural_transformation J.comp C A'.map D.map 
            proof -
              have "χ'.A.map   = A'.map"
                using φ φ.preserves_arr A'.map_def χ'.A.is_extensional by auto
              moreover have "D'   = D.map"
                using φ D.map_def D'.is_extensional by auto
              ultimately show "natural_transformation J.comp C A'.map D.map "
                using χ'.natural_transformation_axioms φ.natural_transformation_axioms
                      horizontal_composite [of J.comp J'    C χ'.A.map D' χ']
                by simp
            qed
            interpret χ: cone J.comp C D.map a'  ..
            have *: "∃!f. «f : a'  a»  D.cones_map f π = "
              using π.is_universal χ.cone_axioms by simp
            show "∃!f. «f : a'  a»  D'.cones_map f ?π' = χ'"
            proof -
              have "f. «f : a'  a»  D'.cones_map f ?π' = χ'"
              proof -
                obtain f where f: "«f : a'  a»  D.cones_map f π = "
                  using * by blast
                have "D'.cones_map f ?π' = χ'"
                proof
                  fix j'
                  show "D'.cones_map f ?π' j' = χ' j'"
                  proof (cases "J'.arr j'")
                    assume j': "¬ J'.arr j'"
                    show "D'.cones_map f ?π' j' = χ' j'"
                      using f j' χ'.is_extensional π'.cone_axioms by auto
                    next
                    assume j': "J'.arr j'"
                    show "D'.cones_map f ?π' j' = χ' j'"
                    proof -
                      have "D'.cones_map f ?π' j' = π (the_inv_into I φ j')  f"
                        using f j' π'.cone_axioms by auto
                      also have "... = D.cones_map f π (the_inv_into I φ j')"
                      proof -
                        have "arr f  dom f = a'  cod f = a"
                          using f by blast
                        thus ?thesis
                          using φ'.preserves_arr π.cone_χ j' by auto
                      qed
                      also have "... = (χ'  ) (the_inv_into I φ j')"
                        using f by simp
                      also have "... = χ' j'"
                        using assms(2) j' 2 bij_betw_def [of φ I I'] bij_betw_imp_inj_on
                              φ'.preserves_arr f_the_inv_into_f
                        by fastforce
                      finally show ?thesis by simp
                    qed
                  qed
                qed
                thus ?thesis using f by blast
              qed
              moreover have "f f'.  «f : a'  a»; D'.cones_map f ?π' = χ';
                                      «f' : a'  a»; D'.cones_map f' ?π' = χ' 
                                          f = f'"
              proof -
                fix f f'
                assume f: "«f : a'  a»" and f': "«f' : a'  a»"
                and fχ': "D'.cones_map f ?π' = χ'" and f'χ': "D'.cones_map f' ?π' = χ'"
                have "D.cones_map f π = χ'    D.cones_map f' π = χ' o "
                proof (intro conjI)
                  show "D.cones_map f π = χ'  "
                  proof
                    fix j
                    have "¬ J.arr j  D.cones_map f π j = (χ'  ) j"
                      using f fχ' π.cone_axioms χ.is_extensional by auto
                    moreover have "J.arr j  D.cones_map f π j = (χ'  ) j"
                    proof -
                      assume j: "J.arr j"
                      have 1: "j = the_inv_into I φ (φ j)"
                        using assms(2) j φ the_inv_into_f_f bij_betw_imp_inj_on J.arr_char
                        by metis
                      have "D.cones_map f π j = D.cones_map f π (the_inv_into I φ (φ j))"
                        using 1 by simp
                      also have "... = (χ'  ) j"
                        using f j fχ' 1 π.cone_axioms π'.cone_axioms φ.preserves_arr by auto
                      finally show "D.cones_map f π j = (χ'  ) j" by blast
                    qed
                    ultimately show "D.cones_map f π j = (χ'  ) j" by blast
                  qed
                  show "D.cones_map f' π = χ'  "
                  proof
                    fix j
                    have "¬ J.arr j  D.cones_map f' π j = (χ'  ) j"
                      using f' fχ' π.cone_axioms χ.is_extensional by auto
                    moreover have "J.arr j  D.cones_map f' π j = (χ'  ) j"
                    proof -
                      assume j: "J.arr j"
                      have 1: "j = the_inv_into I φ (φ j)"
                        using assms(2) j φ the_inv_into_f_f bij_betw_imp_inj_on J.arr_char
                        by metis
                      have "D.cones_map f' π j = D.cones_map f' π (the_inv_into I φ (φ j))"
                        using 1 by simp
                      also have "... = (χ'  ) j"
                        using f' j f'χ' 1 π.cone_axioms π'.cone_axioms φ.preserves_arr by auto
                      finally show "D.cones_map f' π j = (χ'  ) j" by blast
                    qed
                    ultimately show "D.cones_map f' π j = (χ'  ) j" by blast
                  qed
                qed
                thus "f = f'"
                  using f f' * by auto
              qed
              ultimately show ?thesis by blast
            qed
          qed
        qed
        have "has_as_product J' D' a"
          using has_as_product_def π'.product_cone_axioms by auto
        thus "a. has_as_product J' D' a" by blast
      qed
    qed

    lemma ide_is_unary_product:
    assumes "ide a"
    shows "m n :: nat. m  n  has_as_product (discrete_category.comp {m :: nat} (n :: nat))
                                                  (λi. if i = m then a else null) a"
    proof -
      fix m n :: nat
      assume neq: "m  n"
      have "{m :: nat}  UNIV"
      proof -
        have "finite {m :: nat}" by simp
        moreover have "¬finite (UNIV :: nat set)" by simp
        ultimately show ?thesis by fastforce
      qed
      interpret J: discrete_category "{m :: nat}" n :: nat›
         using neq {m :: nat}  UNIV› by unfold_locales auto
      let ?D = "λi. if i = m then a else null"
      interpret D: discrete_diagram J.comp C ?D
        apply unfold_locales
        using assms J.null_char neq
             apply auto
        by metis
      interpret A: constant_functor J.comp C a
        using assms by unfold_locales auto
      show "has_as_product J.comp ?D a"
      proof (unfold has_as_product_def)
        let  = "λi :: nat. if i = m then a else null"
        interpret π: natural_transformation J.comp C A.map ?D 
          using assms J.arr_char J.dom_char J.cod_char
          by unfold_locales auto
        interpret π: cone J.comp C ?D a  ..
        interpret π: product_cone J.comp C ?D a 
        proof
          fix a' χ'
          assume χ': "D.cone a' χ'"
          interpret χ': cone J.comp C ?D a' χ' using χ' by auto
          show "∃!f. «f : a'  a»  D.cones_map f  = χ'"
          proof
            show "«χ' m : a'  a»  D.cones_map (χ' m)  = χ'"
            proof
              show 1: "«χ' m : a'  a»"
                using χ'.preserves_hom χ'.A.map_def J.arr_char J.dom_char J.cod_char
                by auto
              show "D.cones_map (χ' m)  = χ'"
              proof
                fix j
                show "D.cones_map (χ' m) (λi. if i = m then a else null) j = χ' j"
                  using J.arr_char J.dom_char J.cod_char J.ide_char π.cone_axioms comp_cod_arr
                  apply (cases "j = m")
                   apply simp
                  using χ'.is_extensional by simp
              qed
            qed
            show "f. «f : a'  a»  D.cones_map f  = χ'  f = χ' m"
            proof -
              fix f
              assume f: "«f : a'  a»  D.cones_map f  = χ'"
              show "f = χ' m"
                using assms f χ'.preserves_hom J.arr_char J.dom_char J.cod_char π.cone_axioms
                      comp_cod_arr
                by auto
            qed
          qed
        qed
        show "π. product_cone J.comp C (λi. if i = m then a else null) a π"
          using π.product_cone_axioms by blast
      qed
    qed

    lemma has_unary_products:
    assumes "card I = 1" and "I  UNIV"
    shows "has_products I"
    proof -
      obtain i where i: "I = {i}"
        using assms card_1_singletonE by blast
      obtain n where n: "n  I"
        using assms by auto
      have "has_products {1 :: nat}"
      proof (unfold has_products_def, intro conjI)
        show "{1 :: nat}  UNIV" by auto
        show "(J :: nat comp) D.
                discrete_diagram J (⋅) D  Collect (partial_magma.arr J) = {1}
                    (a. has_as_product J D a)"
        proof
          fix J :: "nat comp"
          show "D. discrete_diagram J (⋅) D  Collect (partial_magma.arr J) = {1}
                        (a. has_as_product J D a)"
          proof (intro allI impI)
            fix D
            assume D: "discrete_diagram J (⋅) D  Collect (partial_magma.arr J) = {1}"
            interpret D: discrete_diagram J C D
              using D by auto
            interpret J: discrete_category {1 :: nat} D.J.null
              by (metis D D.J.not_arr_null discrete_category.intro mem_Collect_eq)
            have 1: "has_as_product J.comp D (D 1)"
            proof -
              have "has_as_product J.comp (λi. if i = 1 then D 1 else null) (D 1)"
                using ide_is_unary_product D.preserves_ide D.is_discrete D J.null_char
                by (metis J.Null_not_in_Obj insertCI mem_Collect_eq)
              moreover have "D = (λi. if i = 1 then D 1 else null)"
              proof
                fix j
                show "D j = (if j = 1 then D 1 else null)"
                  using D D.is_extensional by auto
              qed
              ultimately show ?thesis by simp
            qed
            moreover have "J = J.comp"
            proof -
              have "j j'. J j j' = J.comp j j'"
              proof -
                fix j j'
                show "J j j' = J.comp j j'"
                  using J.comp_char D.is_discrete D
                  by (metis D.J.category_axioms D.J.ext D.J.ide_def J.null_char
                            category.seqE mem_Collect_eq)
              qed
              thus ?thesis by auto
            qed
            ultimately show "a. has_as_product J D a" by auto
          qed
        qed
      qed
      moreover have "bij_betw (λk. if k = 1 then i else n) {1 :: nat} I"
        using i by (intro bij_betwI') auto
      ultimately show "has_products I"
        using assms has_products_preserved_by_bijection by blast
    qed

  end

  subsection "Equalizers"

  text‹
    An \emph{equalizer} in a category @{term C} is a limit of a parallel pair
    of arrows in @{term C}.
›

  locale parallel_pair_diagram =
    J: parallel_pair +
    C: category C
  for C :: "'c comp"      (infixr "" 55)
  and f0 :: 'c
  and f1 :: 'c +
  assumes is_parallel: "C.par f0 f1"
  begin

    no_notation J.comp   (infixr "" 55)
    notation J.comp      (infixr "J" 55)

    definition map
    where "map  (λj. if j = J.Zero then C.dom f0
                       else if j = J.One then C.cod f0
                       else if j = J.j0 then f0
                       else if j = J.j1 then f1
                       else C.null)"

    lemma map_simp:
    shows "map J.Zero = C.dom f0"
    and "map J.One = C.cod f0"
    and "map J.j0 = f0"
    and "map J.j1 = f1"
    proof -
      show "map J.Zero = C.dom f0"
        using map_def by metis
      show "map J.One = C.cod f0"
        using map_def J.Zero_not_eq_One by metis
      show "map J.j0 = f0"
        using map_def J.Zero_not_eq_j0 J.One_not_eq_j0 by metis
      show "map J.j1 = f1"
        using map_def J.Zero_not_eq_j1 J.One_not_eq_j1 J.j0_not_eq_j1 by metis
    qed

  end

  sublocale parallel_pair_diagram  diagram J.comp C map
    apply unfold_locales
        apply (simp add: J.arr_char map_def)
    using map_def is_parallel J.arr_char J.cod_simp J.dom_simp
       apply auto[2]
  proof -
    show 1: "j. J.arr j  C.cod (map j) = map (J.cod j)"
    proof -
      fix j
      assume j: "J.arr j"
      show "C.cod (map j) = map (J.cod j)"
      proof -
        have "j = J.Zero  j = J.One  ?thesis" using is_parallel map_def by auto
        moreover have "j = J.j0  j = J.j1  ?thesis"
          using is_parallel map_def J.Zero_not_eq_j0 J.One_not_eq_j0 J.Zero_not_eq_One
                J.Zero_not_eq_j1 J.One_not_eq_j1 J.Zero_not_eq_One J.cod_simp
          by presburger
        ultimately show ?thesis using j J.arr_char by fast
      qed
    qed
    next
    fix j j'
    assume jj': "J.seq j' j"
    show "map (j' J j) = map j'  map j"
    proof -
      have 1: "(j = J.Zero  j'  J.One)  (j  J.Zero  j' = J.One)"
        using jj' J.seq_char by blast
      moreover have "j = J.Zero  j'  J.One  ?thesis"
        using jj' map_def is_parallel J.arr_char J.cod_simp J.dom_simp J.seq_char
        by (metis (no_types, lifting) C.arr_dom_iff_arr C.comp_arr_dom C.dom_dom
            J.comp_arr_dom)
      moreover have "j  J.Zero  j' = J.One  ?thesis"
        using jj' J.ide_char map_def J.Zero_not_eq_One is_parallel
        by (metis (no_types, lifting) C.arr_cod_iff_arr C.comp_arr_dom C.comp_cod_arr
            C.comp_ide_arr C.ext C.ide_cod J.comp_simp(2))
      ultimately show ?thesis by blast
    qed
  qed

  context parallel_pair_diagram
  begin

    definition mkCone
    where "mkCone e  λj. if J.arr j then if j = J.Zero then e else f0  e else C.null"

    abbreviation is_equalized_by
    where "is_equalized_by e  C.seq f0 e  f0  e = f1  e"

    abbreviation has_as_equalizer
    where "has_as_equalizer e  limit_cone (C.dom e) (mkCone e)"

    lemma cone_mkCone:
    assumes "is_equalized_by e"
    shows "cone (C.dom e) (mkCone e)"
    proof -
      interpret E: constant_functor J.comp C ‹C.dom e
        apply unfold_locales using assms by auto
      show "cone (C.dom e) (mkCone e)"
        using assms mkCone_def apply unfold_locales
            apply auto[2]
        using C.dom_comp C.seqE C.cod_comp J.Zero_not_eq_One J.arr_char' J.cod_char map_def
          apply (metis (no_types, lifting) C.not_arr_null parallel_pair.cod_simp(1) preserves_arr)
      proof -
        fix j
        assume j: "J.arr j"
        show "map j  mkCone e (J.dom j) = mkCone e j"
        proof -
          have 1: "a. if a = J.Zero then map a = C.dom f0
                        else if a = J.One then map a = C.cod f0
                        else if a = J.j0 then map a = f0
                        else if a = J.j1 then map a = f1
                        else map a = C.null"
            using map_def by auto
          hence 2: "map j = f1  j = J.One  j = J.Zero  j = J.j0"
            using j parallel_pair.arr_char by meson
          have "j = J.Zero  map j  mkCone e (J.dom j) = mkCone e j"
            using assms j 1 2 mkCone_def C.cod_comp
            by (metis (no_types, lifting) C.comp_cod_arr J.arr_char J.dom_simp(2-4) is_parallel)
          thus ?thesis
            using assms 1 j
            by (metis (no_types, lifting) C.comp_cod_arr C.seqE mkCone_def J.dom_simp(1))
        qed
        next
        show "j. J.arr j  mkCone e (J.cod j)  E.map j = mkCone e j"
        proof -
          fix j
          assume j: "J.arr j"
          have "J.cod j = J.Zero  mkCone e (J.cod j)  E.map j = mkCone e j"
            unfolding mkCone_def
            using assms j J.arr_char J.cod_char C.comp_arr_dom mkCone_def J.Zero_not_eq_One
            by (metis (no_types, lifting) C.seqE E.map_simp)
          moreover have "J.cod j  J.Zero  mkCone e (J.cod j)  E.map j = mkCone e j"
            unfolding mkCone_def
            using assms j C.comp_arr_dom by auto
          ultimately show "mkCone e (J.cod j)  E.map j = mkCone e j" by blast
        qed
      qed
    qed

    lemma is_equalized_by_cone:
    assumes "cone a χ"
    shows "is_equalized_by (χ (J.Zero))"
    proof -
      interpret χ: cone J.comp C map a χ
        using assms by auto
      show ?thesis
        using assms J.arr_char J.dom_char J.cod_char
              J.One_not_eq_j0 J.One_not_eq_j1 J.Zero_not_eq_j0 J.Zero_not_eq_j1 J.j0_not_eq_j1
        by (metis (no_types, lifting) Limit.cone_def χ.is_natural_1 χ.naturality
            χ.preserves_reflects_arr constant_functor.map_simp map_simp(3) map_simp(4))
    qed

    lemma mkCone_cone:
    assumes "cone a χ"
    shows "mkCone (χ J.Zero) = χ"
    proof -
      interpret χ: cone J.comp C map a χ
        using assms by auto
      have 1: "is_equalized_by (χ J.Zero)"
        using assms is_equalized_by_cone by blast
      show ?thesis
      proof
        fix j
        have "j = J.Zero  mkCone (χ J.Zero) j = χ j"
          using mkCone_def χ.is_extensional by simp
        moreover have "j = J.One  j = J.j0  j = J.j1  mkCone (χ J.Zero) j = χ j"
          using J.arr_char J.cod_char J.dom_char J.seq_char mkCone_def
                χ.is_natural_1 χ.is_natural_2 χ.A.map_simp map_def
          by (metis (no_types, lifting) J.Zero_not_eq_j0 J.dom_simp(2))
        ultimately have "J.arr j  mkCone (χ J.Zero) j = χ j"
          using J.arr_char by auto
        thus "mkCone (χ J.Zero) j = χ j"
          using mkCone_def χ.is_extensional by fastforce
      qed
    qed

  end

  locale equalizer_cone =
    J: parallel_pair +
    C: category C +
    D: parallel_pair_diagram C f0 f1 +
    limit_cone J.comp C D.map "C.dom e" "D.mkCone e"
  for C :: "'c comp"      (infixr "" 55)
  and f0 :: 'c
  and f1 :: 'c
  and e :: 'c
  begin

    lemma equalizes:
    shows "D.is_equalized_by e"
    proof
      show 1: "C.seq f0 e"
      proof (intro C.seqI)
        show "C.arr e" using ide_apex C.arr_dom_iff_arr by fastforce
        show "C.arr f0"
          using D.map_simp D.preserves_arr J.arr_char by metis
        show "C.dom f0 = C.cod e"
          using J.arr_char J.ide_char D.mkCone_def D.map_simp preserves_cod [of J.Zero]
          by auto
      qed
      hence 2: "C.seq f1 e"
        using D.is_parallel by fastforce
      show "f0  e = f1  e"
        using D.map_simp D.mkCone_def J.arr_char naturality [of J.j0] naturality [of J.j1]
        by force
    qed

    lemma is_universal':
    assumes "D.is_equalized_by e'"
    shows "∃!h. «h : C.dom e'  C.dom e»  e  h = e'"
    proof -
      have "D.cone (C.dom e') (D.mkCone e')"
        using assms D.cone_mkCone by blast
      moreover have 0: "D.cone (C.dom e) (D.mkCone e)" ..
      ultimately have 1: "∃!h. «h : C.dom e'  C.dom e» 
                               D.cones_map h (D.mkCone e) = D.mkCone e'"
        using is_universal [of "C.dom e'" "D.mkCone e'"] by auto
      have 2: "h. «h : C.dom e'  C.dom e» 
                    D.cones_map h (D.mkCone e) = D.mkCone e'  e  h = e'"
      proof -
        fix h
        assume h: "«h : C.dom e'  C.dom e»"
        show "D.cones_map h (D.mkCone e) = D.mkCone e'  e  h = e'"
        proof
          assume 3: "D.cones_map h (D.mkCone e) = D.mkCone e'"
          show "e  h = e'"
          proof -
            have "e' = D.mkCone e' J.Zero"
              using D.mkCone_def J.arr_char by simp
            also have "... = D.cones_map h (D.mkCone e) J.Zero"
              using 3 by simp
            also have "... = e  h"
              using 0 h D.mkCone_def J.arr_char by auto
            finally show ?thesis by auto
          qed
          next
          assume e': "e  h = e'"
          show "D.cones_map h (D.mkCone e) = D.mkCone e'"
          proof
            fix j
            have "¬J.arr j  D.cones_map h (D.mkCone e) j = D.mkCone e' j"
              using h cone_axioms D.mkCone_def by auto
            moreover have "j = J.Zero  D.cones_map h (D.mkCone e) j = D.mkCone e' j"
              using h e' cone_χ D.mkCone_def J.arr_char [of J.Zero] by force
            moreover have
                "J.arr j  j  J.Zero  D.cones_map h (D.mkCone e) j = D.mkCone e' j"
            proof -
              assume j: "J.arr j  j  J.Zero"
              have "D.cones_map h (D.mkCone e) j = C (D.mkCone e j) h"
                using j h equalizes D.mkCone_def D.cone_mkCone J.arr_char
                      J.Zero_not_eq_One J.Zero_not_eq_j0 J.Zero_not_eq_j1
                by auto
              also have "... = (f0  e)  h"
                using j D.mkCone_def J.arr_char J.Zero_not_eq_One J.Zero_not_eq_j0
                      J.Zero_not_eq_j1
                by auto
              also have "... = f0  e  h"
                using h equalizes C.comp_assoc by blast
              also have "... = D.mkCone e' j"
                using j e' h equalizes D.mkCone_def J.arr_char [of J.One] J.Zero_not_eq_One
                by auto
              finally show ?thesis by auto
            qed
            ultimately show "D.cones_map h (D.mkCone e) j = D.mkCone e' j" by blast
          qed
        qed
      qed
      thus ?thesis using 1 by blast
    qed

    lemma induced_arrowI':
    assumes "D.is_equalized_by e'"
    shows "«induced_arrow (C.dom e') (D.mkCone e') : C.dom e'  C.dom e»"
    and "e  induced_arrow (C.dom e') (D.mkCone e') = e'"
    proof -
      interpret A': constant_functor J.comp C ‹C.dom e'
        using assms by (unfold_locales, auto)
      have cone: "D.cone (C.dom e') (D.mkCone e')"
        using assms D.cone_mkCone [of e'] by blast
      have "e  induced_arrow (C.dom e') (D.mkCone e') =
              D.cones_map (induced_arrow (C.dom e') (D.mkCone e')) (D.mkCone e) J.Zero"
        using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by force
      also have "... = e'"
      proof -
        have
            "D.cones_map (induced_arrow (C.dom e') (D.mkCone e')) (D.mkCone e) =
             D.mkCone e'"
          using cone induced_arrowI by blast
        thus ?thesis
          using J.arr_char D.mkCone_def by simp
      qed
      finally have 1: "e  induced_arrow (C.dom e') (D.mkCone e') = e'"
        by auto
      show "«induced_arrow (C.dom e') (D.mkCone e') : C.dom e'  C.dom e»"
        using 1 cone induced_arrowI by simp
      show "e  induced_arrow (C.dom e') (D.mkCone e') = e'"
        using 1 cone induced_arrowI by simp
    qed

  end

  context category
  begin

    definition has_as_equalizer
    where "has_as_equalizer f0 f1 e  par f0 f1  parallel_pair_diagram.has_as_equalizer C f0 f1 e"

    definition has_equalizers
    where "has_equalizers = (f0 f1. par f0 f1  (e. has_as_equalizer f0 f1 e))"

  end

  section "Limits by Products and Equalizers"
 
  text‹
    A category with equalizers has limits of shape @{term J} if it has products
    indexed by the set of arrows of @{term J} and the set of objects of @{term J}.
    The proof is patterned after \cite{MacLane}, Theorem 2, page 109:
    \begin{quotation}
       \noindent
       ``The limit of F: J → C› is the equalizer e›
       of f, g: Πi Fi → Πu Fcod u (u ∈ arr J, i ∈ J)›
       where pu f = pcod u, pu g = Fu o pdom u;
       the limiting cone μ› is μj = pj e›, for j ∈ J›.''
    \end{quotation}
›

  locale category_with_equalizers =
    category C
  for C :: "'c comp"      (infixr "" 55) +
  assumes has_equalizers: "has_equalizers"
  begin

    lemma has_limits_if_has_products:
    fixes J :: "'j comp"  (infixr "J" 55)
    assumes "category J" and "has_products (Collect (partial_magma.ide J))"
    and "has_products (Collect (partial_magma.arr J))"
    shows "has_limits_of_shape J"
    proof (unfold has_limits_of_shape_def)
      interpret J: category J using assms(1) by auto
      have "D. diagram J C D  (a χ. limit_cone J C D a χ)"
      proof -
        fix D
        assume D: "diagram J C D"
        interpret D: diagram J C D using D by auto

        text‹
          First, construct the two required products and their cones.
›
        interpret Obj: discrete_category ‹Collect J.ide› J.null
          using J.not_arr_null J.ideD(1) mem_Collect_eq by (unfold_locales, blast)
        interpret Δo: discrete_diagram_from_map ‹Collect J.ide› C D J.null
          using D.preserves_ide by (unfold_locales, auto)
        have "p. has_as_product Obj.comp Δo.map p"
          using assms(2) Δo.diagram_axioms has_products_def Obj.arr_char
          by (metis (no_types, lifting) Collect_cong Δo.discrete_diagram_axioms mem_Collect_eq)
        from this obtain Πo πo where πo: "product_cone Obj.comp C Δo.map Πo πo"
           using ex_productE [of Obj.comp Δo.map] by auto
        interpret πo: product_cone Obj.comp C Δo.map Πo πo using πo by auto
        have πo_in_hom: "j. Obj.arr j  «πo j : Πo  D j»"
          using πo.preserves_dom πo.preserves_cod Δo.map_def by auto

        interpret Arr: discrete_category ‹Collect J.arr› J.null
          using J.not_arr_null by (unfold_locales, blast)
        interpret Δa: discrete_diagram_from_map ‹Collect J.arr› C D o J.cod› J.null
          by (unfold_locales, auto)
        have "p. has_as_product Arr.comp Δa.map p"
          using assms(3) has_products_def [of "Collect J.arr"] Δa.discrete_diagram_axioms
          by blast
        from this obtain Πa πa where πa: "product_cone Arr.comp C Δa.map Πa πa"
          using ex_productE [of Arr.comp Δa.map] by auto
        interpret πa: product_cone Arr.comp C Δa.map Πa πa using πa by auto
        have πa_in_hom: "j. Arr.arr j  «πa j : Πa  D (J.cod j)»"
          using πa.preserves_cod πa.preserves_dom Δa.map_def by auto

        text‹
           Next, construct a parallel pair of arrows f, g: Πo → Πa›
           that expresses the commutativity constraints imposed by the diagram.
›
        interpret Πo: constant_functor Arr.comp C Πo
          using πo.ide_apex by (unfold_locales, auto)
        let  = "λj. if Arr.arr j then πo (J.cod j) else null"
        interpret χ: cone Arr.comp C Δa.map Πo 
          using πo.ide_apex πo_in_hom Δa.map_def Δo.map_def Δo.is_discrete πo.is_natural_2
                comp_cod_arr
          by (unfold_locales, auto)

        let ?f = "πa.induced_arrow Πo "
        have f_in_hom: "«?f : Πo  Πa»"
          using χ.cone_axioms πa.induced_arrowI by blast
        have f_map: "Δa.cones_map ?f πa = "
          using χ.cone_axioms πa.induced_arrowI by blast
        have ff: "j. J.arr j  πa j  ?f = πo (J.cod j)"
        proof -
          fix j
          assume j: "J.arr j"
          have "πa j  ?f = Δa.cones_map ?f πa j"
            using f_in_hom πa.is_cone πa.is_extensional by auto
          also have "... = πo (J.cod j)"
            using j f_map by fastforce
          finally show "πa j  ?f = πo (J.cod j)" by auto
        qed

        let ?χ' = "λj. if Arr.arr j then D j  πo (J.dom j) else null"
        interpret χ': cone Arr.comp C Δa.map Πo ?χ'
          using πo.ide_apex πo_in_hom Δo.map_def Δa.map_def comp_arr_dom comp_cod_arr
          by (unfold_locales, auto)
        let ?g = "πa.induced_arrow Πo ?χ'"
        have g_in_hom: "«?g : Πo  Πa»"
          using χ'.cone_axioms πa.induced_arrowI by blast
        have g_map: "Δa.cones_map ?g πa = ?χ'"
          using χ'.cone_axioms πa.induced_arrowI by blast
        have gg: "j. J.arr j  πa j  ?g = D j  πo (J.dom j)"
        proof -
          fix j
          assume j: "J.arr j"
          have "πa j  ?g = Δa.cones_map ?g πa j"
            using g_in_hom πa.is_cone πa.is_extensional by force
          also have "... = D j  πo (J.dom j)"
            using j g_map by fastforce
          finally show "πa j  ?g = D j  πo (J.dom j)" by auto
        qed

        interpret PP: parallel_pair_diagram C ?f ?g
          using f_in_hom g_in_hom
          by (elim in_homE, unfold_locales, auto)

        from PP.is_parallel obtain e where equ: "PP.has_as_equalizer e"
          using has_equalizers has_equalizers_def has_as_equalizer_def by blast
        interpret EQU: limit_cone PP.J.comp C PP.map ‹dom e ‹PP.mkCone e
          using equ by auto
        interpret EQU: equalizer_cone C ?f ?g e ..

        text‹
          An arrow @{term h} with @{term "cod h = Πo"} equalizes @{term f} and @{term g}
          if and only if it satisfies the commutativity condition required for a cone over
          @{term D}.
›
        have E: "h. «h : dom h  Πo» 
                   ?f  h = ?g  h  (j. J.arr j   j  h = ?χ' j  h)"
        proof
          fix h
          assume h: "«h : dom h  Πo»"
          show "?f  h = ?g  h  j. J.arr j   j  h = ?χ' j  h"
          proof -
            assume E: "?f  h = ?g  h"
            have "j. J.arr j   j  h = ?χ' j  h"
            proof -
              fix j
              assume j: "J.arr j"
              have " j  h = Δa.cones_map ?f πa j  h"
                using j f_map by fastforce
              also have "... = πa j  ?f  h"
                using j f_in_hom Δa.map_def πa.cone_χ comp_assoc by auto
              also have "... = πa j  ?g  h"
                using j E by simp
              also have "... = Δa.cones_map ?g πa j  h"
                using j g_in_hom Δa.map_def πa.cone_χ comp_assoc by auto
              also have "... = ?χ' j  h"
                using j g_map by force
              finally show " j  h = ?χ' j  h" by auto
            qed
            thus "j. J.arr j   j  h = ?χ' j  h" by blast
          qed
          show "j. J.arr j   j  h = ?χ' j  h  ?f  h = ?g  h"
          proof -
            assume 1: "j. J.arr j   j  h = ?χ' j  h"
            have 2: "j. j  Collect J.arr  πa j  ?f  h = πa j  ?g  h"
            proof -
              fix j
              assume j: "j  Collect J.arr"
              have "πa j  ?f  h = (πa j  ?f)  h"
                using comp_assoc by simp
              also have "... =  j  h"
              proof -
                have "πa j  ?f = Δa.cones_map ?f πa j"
                  using j f_in_hom πa.cone_axioms Δa.map_def πa.cone_χ by auto
                thus ?thesis using f_map by fastforce
              qed
              also have "... = ?χ' j  h"
                using 1 j by auto
              also have "... = (πa j  ?g)  h"
              proof -
                have "πa j  ?g = Δa.cones_map ?g πa j"
                  using j g_in_hom πa.cone_axioms Δa.map_def πa.cone_χ by auto
                thus ?thesis using g_map by simp
              qed
              also have "... = πa j  ?g  h"
                using comp_assoc by simp
              finally show "πa j  ?f  h = πa j  ?g  h"
                by auto
            qed
            show "C ?f h = C ?g h"
            proof -
              have "j. Arr.arr j  «πa j  ?f  h : dom h  Δa.map j»"
                using f_in_hom h πa_in_hom by (elim in_homE, auto)
              hence 3: "∃!k. «k : dom h  Πa»  (j. Arr.arr j  πa j  k = πa j  ?f  h)"
                using h πa πa.is_universal' [of "dom h" "λj. πa j  ?f  h"] Δa.map_def
                      ide_dom [of h]
                by blast
              have 4: "P x x'. ∃!k. P k x  P x x  P x' x  x' = x" by auto
              let ?P = "λ k x. «k : dom h  Πa» 
                               (j. j  Collect J.arr  πa j  k = πa j  x)"
              have "?P (?g  h) (?g  h)"
                using g_in_hom h by force
              moreover have "?P (?f  h) (?g  h)"
                using 2 f_in_hom g_in_hom h by force
              ultimately show ?thesis
                using 3 4 [of ?P "?f  h" "?g  h"] by auto
            qed
          qed
        qed
        have E': "e. «e : dom e  Πo» 
                   ?f  e = ?g  e 
                   (j. J.arr j 
                           (D (J.cod j)  πo (J.cod j)  e)  dom e = D j  πo (J.dom j)  e)"
        proof -
          have 1: "e j. «e : dom e  Πo»  J.arr j 
                           j  e = (D (J.cod j)  πo (J.cod j)  e)  dom e"
          proof -
            fix e j
            assume e: "«e : dom e  Πo»"
            assume j: "J.arr j"
            have "«πo (J.cod j)  e : dom e  D (J.cod j)»"
              using e j πo_in_hom by auto
            thus " j  e = (D (J.cod j)  πo (J.cod j)  e)  dom e"
              using j comp_arr_dom comp_cod_arr by (elim in_homE, auto)
          qed
          have 2: "e j. «e : dom e  Πo»  J.arr j  ?χ' j  e = D j  πo (J.dom j)  e"
          proof -
            fix e j
            assume e: "«e : dom e  Πo»"
            assume j: "J.arr j"
            show "?χ' j  e = D j  πo (J.dom j)  e"
              using j comp_assoc by fastforce
          qed
          show "e. «e : dom e  Πo» 
                   ?f  e = ?g  e 
                     (j. J.arr j 
                           (D (J.cod j)  πo (J.cod j)  e)  dom e = D j  πo (J.dom j)  e)"
            using 1 2 E by presburger
        qed
        text‹
          The composites of @{term e} with the projections from the product @{term Πo}
          determine a limit cone @{term μ} for @{term D}.  The component of @{term μ}
          at an object @{term j} of @{term[source=true] J} is the composite @{term "C (πo j) e"}.
          However, we need to extend @{term μ} to all arrows @{term j} of @{term[source=true] J},
          so the correct definition is @{term "μ j = C (D j) (C (πo (J.dom j)) e)"}.
›
        have e_in_hom: "«e : dom e  Πo»"
          using EQU.equalizes f_in_hom in_homI
          by (metis (no_types, lifting) seqE in_homE)
        have e_map: "C ?f e = C ?g e"
          using EQU.equalizes f_in_hom in_homI by fastforce
        interpret domE: constant_functor J C ‹dom e
          using e_in_hom by (unfold_locales, auto)
        let  = "λj. if J.arr j then D j  πo (J.dom j)  e else null"
        have μ: "j. J.arr j  « j : dom e  D (J.cod j)»"
        proof -
          fix j
          assume j: "J.arr j"
          show "« j : dom e  D (J.cod j)»"
            using j e_in_hom πo_in_hom [of "J.dom j"] by auto
        qed
        interpret μ: cone J C D ‹dom e 
          using μ comp_cod_arr e_in_hom e_map E'
            apply unfold_locales
               apply auto
          by (metis D.is_natural_1 comp_assoc)
        text‹
          If @{term τ} is any cone over @{term D} then @{term τ} restricts to a cone over
          @{term Δo} for which the induced arrow to @{term Πo} equalizes @{term f} and @{term g}.
›
        have R: "a τ. cone J C D a τ 
                        cone Obj.comp C Δo.map a (Δo.mkCone τ) 
                        ?f  πo.induced_arrow a (Δo.mkCone τ)
                           = ?g  πo.induced_arrow a (Δo.mkCone τ)"
        proof -
          fix a τ
          assume cone_τ: "cone J C D a τ"
          interpret τ: cone J C D a τ using cone_τ by auto
          interpret A: constant_functor Obj.comp C a
            using τ.ide_apex by (unfold_locales, auto)
          interpret τo: cone Obj.comp C Δo.map a ‹Δo.mkCone τ
            using A.value_is_ide Δo.map_def comp_cod_arr comp_arr_dom
            by (unfold_locales, auto)
          let ?e = "πo.induced_arrow a (Δo.mkCone τ)"
          have mkCone_τ: "Δo.mkCone τ  Δo.cones a"
            using τo.cone_axioms by auto
          have e: "«?e : a  Πo»"
            using mkCone_τ πo.induced_arrowI by simp
          have ee: "j. J.ide j  πo j  ?e = τ j"
          proof -
            fix j
            assume j: "J.ide j"
            have "πo j  ?e = Δo.cones_map ?e πo j"
              using j e πo.cone_axioms by force
            also have "... = Δo.mkCone τ j"
              using j mkCone_τ πo.induced_arrowI [of "Δo.mkCone τ" a] by fastforce
            also have "... = τ j"
              using j by simp
            finally show "πo j  ?e = τ j" by auto
          qed
          have "j. J.arr j 
                      (D (J.cod j)  πo (J.cod j)  ?e)  dom ?e = D j  πo (J.dom j)  ?e"
          proof -
            fix j
            assume j: "J.arr j"
            have 1: "«πo (J.cod j) : Πo  D (J.cod j)»" using j πo_in_hom by simp
            have 2: "(D (J.cod j)  πo (J.cod j)  ?e)  dom ?e
                        = D (J.cod j)  πo (J.cod j)  ?e"
            proof -
              have "seq (D (J.cod j)) (πo (J.cod j))"
                using j 1 by auto
              moreover have "seq (πo (J.cod j)) ?e"
                using j e by fastforce
              ultimately show ?thesis using comp_arr_dom by auto
            qed
            also have 3: "... = πo (J.cod j)  ?e"
              using j e 1 comp_cod_arr by (elim in_homE, auto)
            also have "... = D j  πo (J.dom j)  ?e"
              using j e ee 2 3 τ.naturality τ.A.map_simp τ.ide_apex comp_cod_arr by auto
            finally show "(D (J.cod j)  πo (J.cod j)  ?e)  dom ?e = D j  πo (J.dom j)  ?e"
              by auto
          qed
          hence "C ?f ?e = C ?g ?e"
            using E' πo.induced_arrowI τo.cone_axioms mem_Collect_eq by blast
          thus "cone Obj.comp C Δo.map a (Δo.mkCone τ)  C ?f ?e = C ?g ?e"
            using τo.cone_axioms by auto
        qed
        text‹
          Finally, show that @{term μ} is a limit cone.
›
        interpret μ: limit_cone J C D ‹dom e 
        proof
          fix a τ
          assume cone_τ: "cone J C D a τ"
          interpret τ: cone J C D a τ using cone_τ by auto
          interpret A: constant_functor Obj.comp C a
            using τ.ide_apex by unfold_locales auto
          have cone_τo: "cone Obj.comp C Δo.map a (Δo.mkCone τ)"
            using A.value_is_ide Δo.map_def D.preserves_ide comp_cod_arr comp_arr_dom
                  τ.preserves_hom
            by unfold_locales auto
          show "∃!h. «h : a  dom e»  D.cones_map h  = τ"
          proof
            let ?e' = "πo.induced_arrow a (Δo.mkCone τ)"
            have e'_in_hom: "«?e' : a  Πo»"
              using cone_τ R πo.induced_arrowI by auto
            have e'_map: "?f  ?e' = ?g  ?e'  Δo.cones_map ?e' πo = Δo.mkCone τ"
              using cone_τ R πo.induced_arrowI [of "Δo.mkCone τ" a] by auto
            have equ: "PP.is_equalized_by ?e'"
              using e'_map e'_in_hom f_in_hom seqI' by blast
            let ?h = "EQU.induced_arrow a (PP.mkCone ?e')"
            have h_in_hom: "«?h : a  dom e»"
              using EQU.induced_arrowI PP.cone_mkCone [of ?e'] e'_in_hom equ by fastforce
            have h_map: "PP.cones_map ?h (PP.mkCone e) = PP.mkCone ?e'"
              using EQU.induced_arrowI [of "PP.mkCone ?e'" a] PP.cone_mkCone [of ?e']
                    e'_in_hom equ
              by fastforce
            have 3: "D.cones_map ?h  = τ"
            proof
              fix j
              have "¬J.arr j  D.cones_map ?h  j = τ j"
                using h_in_hom μ.cone_axioms cone_τ τ.is_extensional by force
              moreover have "J.arr j  D.cones_map ?h  j = τ j"
              proof -
                fix j
                assume j: "J.arr j"
                have 1: "«πo (J.dom j)  e : dom e  D (J.dom j)»"
                  using j e_in_hom πo_in_hom [of "J.dom j"] by auto
                have "D.cones_map ?h  j =  j  ?h"
                  using h_in_hom j μ.cone_axioms by auto
                also have "... = D j  (πo (J.dom j)  e)  ?h"
                  using j comp_assoc by simp
                also have "... = D j  τ (J.dom j)"
                proof -
                  have "(πo (J.dom j)  e)  ?h = τ (J.dom j)"
                  proof -
                    have "(πo (J.dom j)  e)  ?h = πo (J.dom j)  e  ?h"
                      using j 1 e_in_hom h_in_hom πo arrI comp_assoc by auto
                    also have "... = πo (J.dom j)  ?e'"
                      using equ e'_in_hom EQU.induced_arrowI' [of ?e'] by auto
                    also have "... = Δo.cones_map ?e' πo (J.dom j)"
                      using j e'_in_hom πo.cone_axioms by auto
                    also have "... = τ (J.dom j)"
                      using j e'_map by simp
                    finally show ?thesis by auto
                  qed
                  thus ?thesis by simp
                qed
                also have "... = τ j"
                  using j τ.is_natural_1 by simp
                finally show "D.cones_map ?h  j = τ j" by auto
              qed
              ultimately show "D.cones_map ?h  j = τ j" by auto
            qed
            show "«?h : a  dom e»  D.cones_map ?h  = τ"
              using h_in_hom 3 by simp
            show "h'. «h' : a  dom e»  D.cones_map h'  = τ  h' = ?h"
            proof -
              fix h'
              assume h': "«h' : a  dom e»  D.cones_map h'  = τ"
              have h'_in_hom: "«h' : a  dom e»" using h' by simp
              have h'_map: "D.cones_map h'  = τ" using h' by simp
              show "h' = ?h"
              proof -
                have 1: "«e  h' : a  Πo»  ?f  e  h' = ?g  e  h' 
                         Δo.cones_map (C e h') πo = Δo.mkCone τ"
                proof -
                  have 2: "«e  h' : a  Πo»" using h'_in_hom e_in_hom by auto
                  moreover have "?f  e  h' = ?g  e  h'"
                  proof -
                    have "?f  e  h' = (?f  e)  h'"
                      using comp_assoc by auto
                    also have "... = ?g  e  h'"
                      using EQU.equalizes comp_assoc by auto
                    finally show ?thesis by auto
                  qed
                  moreover have "Δo.cones_map (e  h') πo = Δo.mkCone τ"
                  proof
                    have "Δo.cones_map (e  h') πo = Δo.cones_map h' (Δo.cones_map e πo)"
                      using πo.cone_axioms e_in_hom h'_in_hom Δo.cones_map_comp [of e h']
                      by fastforce
                    fix j
                    have "¬Obj.arr j  Δo.cones_map (e  h') πo j = Δo.mkCone τ j"
                      using 2 e_in_hom h'_in_hom πo.cone_axioms by auto
                    moreover have "Obj.arr j  Δo.cones_map (e  h') πo j = Δo.mkCone τ j"
                    proof -
                      assume j: "Obj.arr j"
                      have "Δo.cones_map (e  h') πo j = πo j  e  h'"
                        using 2 j πo.cone_axioms by auto
                      also have "... = (πo j  e)  h'"
                        using comp_assoc by auto
                      also have "... = Δo.mkCone  j  h'"
                        using j e_in_hom πo_in_hom comp_ide_arr [of "D j" "πo j  e"]
                        by fastforce
                      also have "... = Δo.mkCone τ j"
                        using j h' μ.cone_axioms mem_Collect_eq by auto
                      finally show "Δo.cones_map (e  h') πo j = Δo.mkCone τ j" by auto
                    qed
                    ultimately show "Δo.cones_map (e  h') πo j = Δo.mkCone τ j" by auto
                  qed
                  ultimately show ?thesis by auto
                qed
                have "«e  h' : a  Πo»" using 1 by simp
                moreover have "e  h' = ?e'"
                  using 1 cone_τo e'_in_hom e'_map πo.is_universal πo by blast
                ultimately show "h' = ?h"
                  using 1 h'_in_hom h'_map EQU.is_universal' [of "e  h'"]
                        EQU.induced_arrowI' [of ?e'] equ
                  by (elim in_homE) auto
              qed
            qed
          qed
        qed
        have "limit_cone J C D (dom e) " ..
        thus "a μ. limit_cone J C D a μ" by auto
      qed
      thus "D. diagram J C D  (a μ. limit_cone J C D a μ)" by blast
    qed

  end

  section "Limits in a Set Category"

  text‹
    In this section, we consider the special case of limits in a set category.
›

  locale diagram_in_set_category =
    J: category J +
    S: set_category S 𝔄 +
    diagram J S D
  for J :: "'j comp"      (infixr "J" 55)
  and S :: "'s comp"      (infixr "" 55)
  and 𝔄 :: "'a rel"
  and D :: "'j  's"
  begin

    notation S.in_hom ("«_ : _  _»")

    text‹
      An object @{term a} of a set category @{term[source=true] S} is a limit of a diagram in
      @{term[source=true] S} if and only if there is a bijection between the set
      @{term "S.hom S.unity a"} of points of @{term a} and the set of cones over the diagram
      that have apex @{term S.unity}.
›

    lemma limits_are_sets_of_cones:
    shows "has_as_limit a  S.ide a  (φ. bij_betw φ (S.hom S.unity a) (cones S.unity))"
    proof
      text‹
        If has_limit a›, then by the universal property of the limit cone,
        composition in @{term[source=true] S} yields a bijection between @{term "S.hom S.unity a"}
        and @{term "cones S.unity"}.
›
      assume a: "has_as_limit a"
      hence "S.ide a"
        using limit_cone_def cone.ide_apex by metis
      from a obtain χ where χ: "limit_cone a χ" by auto
      interpret χ: limit_cone J S D a χ using χ by auto
      have "bij_betw (λf. cones_map f χ) (S.hom S.unity a) (cones S.unity)"
        using χ.bij_betw_hom_and_cones S.ide_unity by simp
      thus "S.ide a  (φ. bij_betw φ (S.hom S.unity a) (cones S.unity))"
        using ‹S.ide a by blast
      next
      text‹
        Conversely, an arbitrary bijection @{term φ} between @{term "S.hom S.unity a"}
        and cones unity extends pointwise to a natural bijection @{term "Φ a'"} between
        @{term "S.hom a' a"} and @{term "cones a'"}, showing that @{term a} is a limit.

        In more detail, the hypotheses give us a correspondence between points of @{term a}
        and cones with apex @{term "S.unity"}.  We extend this to a correspondence between
        functions to @{term a} and general cones, with each arrow from @{term a'} to @{term a}
        determining a cone with apex @{term a'}.  If @{term "f  hom a' a"} then composition
        with @{term f} takes each point @{term y} of @{term a'} to the point @{term "S f y"}
        of @{term a}.  To this we may apply the given bijection @{term φ} to obtain
        @{term "φ (S f y)  cones S.unity"}.  The component @{term "φ (S f y) j"} at @{term j}
        of this cone is a point of @{term "S.cod (D j)"}.  Thus, @{term "f  hom a' a"} determines
        a cone @{term χf} with apex @{term a'} whose component at @{term j} is the
        unique arrow @{term "χf j"} of @{term[source=true] S} such that
        @{term "χf j  hom a' (cod (D j))"} and @{term "S (χf j) y = φ (S f y) j"}
        for all points @{term y} of @{term a'}.
        The cone @{term χa} corresponding to @{term "a  S.hom a a"} is then a limit cone.
›
      assume a: "S.ide a  (φ. bij_betw φ (S.hom S.unity a) (cones S.unity))"
      hence ide_a: "S.ide a" by auto
      show "has_as_limit a"
      proof -
        from a obtain φ where φ: "bij_betw φ (S.hom S.unity a) (cones S.unity)" by blast
        have X: "f j y.  «f : S.dom f  a»; J.arr j; «y : S.unity  S.dom f» 
                                 «φ (f  y) j : S.unity  S.cod (D j)»"
        proof -
          fix f j y
          assume f: "«f : S.dom f  a»" and j: "J.arr j" and y: "«y : S.unity  S.dom f»"
          interpret χ: cone J S D S.unity φ (S f y)
            using f y φ bij_betw_imp_funcset funcset_mem by blast
          show "«φ (f  y) j : S.unity  S.cod (D j)»" using j by auto
        qed
        text‹
          We want to define the component @{term "χj  S.hom (S.dom f) (S.cod (D j))"}
          at @{term j} of a cone by specifying how it acts by composition on points
          @{term "y  S.hom S.unity (S.dom f)"}.  We can do this because @{term[source=true] S}
          is a set category.
›
        let ?P = "λf j χj. «χj : S.dom f  S.cod (D j)» 
                           (y. «y : S.unity  S.dom f»  χj  y = φ (f  y) j)"
        let  = "λf j. if J.arr j then (THE χj. ?P f j χj) else S.null"
        have χ: "f j.  «f : S.dom f  a»; J.arr j   ?P f j ( f j)"
        proof -
          fix b f j
          assume f: "«f : S.dom f  a»" and j: "J.arr j"
          interpret B: constant_functor J S ‹S.dom f
            using f by (unfold_locales) auto
          have "(λy. φ (f  y) j)  S.hom S.unity (S.dom f)  S.hom S.unity (S.cod (D j))"
            using f j X Pi_I' by simp
          hence "∃!χj. ?P f j χj"
            using f j S.fun_complete' by (elim S.in_homE) auto
          thus "?P f j ( f j)" using j theI' [of "?P f j"] by simp
        qed
        text‹
          The arrows @{term "χ f j"} are in fact the components of a cone with apex
          @{term "S.dom f"}.
›
        have cone: "f. «f : S.dom f  a»  cone (S.dom f) ( f)"
        proof -
          fix f
          assume f: "«f : S.dom f  a»"
          interpret B: constant_functor J S ‹S.dom f
            using f by unfold_locales auto
          show "cone (S.dom f) ( f)"
          proof
            show "j. ¬J.arr j   f j = S.null" by simp
            fix j
            assume j: "J.arr j"
            have 0: "« f j : S.dom f  S.cod (D j)»" using f j χ by simp
            show "S.dom ( f j) = B.map (J.dom j)" using f j χ by auto
            show "S.cod ( f j) = D (J.cod j)" using f j χ by auto
            have par2: "S.par ( f (J.cod j)  B.map j) ( f j)"
              using f j 0 χ [of f "J.cod j"] by (elim S.in_homE, auto)
            have nat: "y. «y : S.unity  S.dom f» 
                              (D j   f (J.dom j))  y =  f j  y 
                              ( f (J.cod j)  B.map j)  y =  f j  y"
            proof -
              fix y
              assume y: "«y : S.unity  S.dom f»"
              show "(D j   f (J.dom j))  y =  f j  y 
                    ( f (J.cod j)  B.map j)  y =  f j  y"
              proof
                have 1: "φ (f  y)  cones S.unity"
                  using f y φ bij_betw_imp_funcset PiE
                        S.seqI S.cod_comp S.dom_comp mem_Collect_eq
                  by fastforce
                interpret χ: cone J S D S.unity φ (f  y)
                  using 1 by simp
                have "(D j   f (J.dom j))  y = D j   f (J.dom j)  y"
                  using S.comp_assoc by simp
                also have "... = D j  φ (f  y) (J.dom j)"
                  using f y χ χ.is_extensional by simp
                also have "... = φ (f  y) j" using j by auto
                also have "... =  f j  y"
                  using f j y χ by force
                finally show "(D j   f (J.dom j))  y =  f j  y" by auto
                have "( f (J.cod j)  B.map j)  y =  f (J.cod j)  y"
                  using j B.map_simp par2 B.value_is_ide S.comp_arr_ide
                  by (metis (no_types, lifting))
                also have "... = φ (f  y) (J.cod j)"
                  using f y χ χ.is_extensional by simp
                also have "... = φ (f  y) j"
                  using j χ.is_natural_2
                  by (metis J.arr_cod χ.A.map_simp J.cod_cod)
                also have "... =  f j  y"
                  using f y χ χ.is_extensional by simp
                finally show "( f (J.cod j)  B.map j)  y =  f j  y" by auto
              qed
            qed
            show "D j   f (J.dom j) =  f j"
            proof -
              have "S.par (D j   f (J.dom j)) ( f j)"
                using f j 0 χ [of f "J.dom j"] by (elim S.in_homE, auto)
              thus ?thesis
                using nat 0
                apply (intro S.arr_eqI' [of "D j   f (J.dom j)" " f j"])
                 apply force
                by auto
            qed
            show " f (J.cod j)  B.map j =  f j"
              using par2 nat 0 f j χ
              apply (intro S.arr_eqI' [of " f (J.cod j)  B.map j" " f j"])
               apply force
              by (metis (no_types, lifting) S.in_homE)
          qed
        qed
        interpret χa: cone J S D a  a using a cone [of a] by fastforce
        text‹
          Finally, show that χ a› is a limit cone.
›
        interpret χa: limit_cone J S D a  a
        proof
          fix a' χ'
          assume cone_χ': "cone a' χ'"
          interpret χ': cone J S D a' χ' using cone_χ' by auto
          show "∃!f. «f : a'  a»  cones_map f ( a) = χ'"
          proof
            let  = "inv_into (S.hom S.unity a) φ"
            have ψ: "  cones S.unity  S.hom S.unity a"
              using φ bij_betw_inv_into bij_betwE by blast
            let ?P = "λf. «f : a'  a» 
                          (y. y  S.hom S.unity a'  f  y =  (cones_map y χ'))"
            have 1: "∃!f. ?P f"
            proof -
              have "(λy.  (cones_map y χ'))  S.hom S.unity a'  S.hom S.unity a"
              proof
                fix x
                assume "x  S.hom S.unity a'"
                hence "«x : S.unity  a'»" by simp
                hence "cones_map x  cones a'  cones S.unity"
                  using cones_map_mapsto [of x] by (elim S.in_homE) auto
                hence "cones_map x χ'  cones S.unity"
                  using cone_χ' by blast
                thus " (cones_map x χ')  S.hom S.unity a"
                  using ψ by auto
              qed
              thus ?thesis
                using S.fun_complete' a χ'.ide_apex by simp
            qed
            let ?f = "THE f. ?P f"
            have f: "?P ?f" using 1 theI' [of ?P] by simp
            have f_in_hom: "«?f : a'  a»" using f by simp
            have f_map: "cones_map ?f ( a) = χ'"
            proof -
              have 1: "cone a' (cones_map ?f ( a))"
              proof -
                have "cones_map ?f  cones a  cones a'"
                  using f_in_hom cones_map_mapsto [of ?f] by (elim S.in_homE) auto
                hence "cones_map ?f ( a)  cones a'"
                  using χa.cone_axioms by blast
                thus ?thesis by simp
              qed
              interpret fχa: cone J S D a' ‹cones_map ?f ( a)
                using 1 by simp
              show ?thesis
              proof
                fix j
                have "¬J.arr j  cones_map ?f ( a) j = χ' j"
                  using 1 χ'.is_extensional fχa.is_extensional by presburger
                moreover have "J.arr j  cones_map ?f ( a) j = χ' j"
                proof -
                  assume j: "J.arr j"
                  show "cones_map ?f ( a) j = χ' j"
                  proof (intro S.arr_eqI' [of "cones_map ?f ( a) j" "χ' j"])
                    show par: "S.par (cones_map ?f ( a) j) (χ' j)"
                      using j χ'.preserves_cod χ'.preserves_dom χ'.preserves_reflects_arr
                            fχa.preserves_cod fχa.preserves_dom fχa.preserves_reflects_arr
                      by presburger
                    fix y
                    assume "«y : S.unity  S.dom (cones_map ?f ( a) j)»"
                    hence y: "«y : S.unity  a'»"
                      using j fχa.preserves_dom by simp
                    have 1: "« a j : a  D (J.cod j)»"
                      using j χa.preserves_hom by force
                    have 2: "«?f  y : S.unity  a»"
                      using f_in_hom y by blast
                    have "cones_map ?f ( a) j  y = ( a j  ?f)  y"
                    proof -
                      have "S.cod ?f = a" using f_in_hom by blast
                      thus ?thesis using j χa.cone_axioms by simp
                    qed
                    also have "... =  a j  ?f  y"
                      using 1 j y f_in_hom S.comp_assoc S.seqI' by blast
                    also have "... = φ (a  ?f  y) j"
                      using 1 2 ide_a f j y χ [of a] by (simp add: S.ide_in_hom)
                    also have "... = φ (?f  y) j"
                      using a 2 y S.comp_cod_arr by (elim S.in_homE, auto)
                    also have "... = φ ( (cones_map y χ')) j"
                      using j y f by simp
                    also have "... = cones_map y χ' j"
                    proof -
                      have "cones_map y χ'  cones S.unity"
                        using cone_χ' y cones_map_mapsto by force
                      hence "φ ( (cones_map y χ')) = cones_map y χ'"
                        using φ bij_betw_inv_into_right [of φ] by simp
                      thus ?thesis by auto
                    qed
                    also have "... = χ' j  y"
                      using cone_χ' j y by auto
                    finally show "cones_map ?f ( a) j  y = χ' j  y"
                      by auto
                  qed
                qed
                ultimately show "cones_map ?f ( a) j = χ' j" by blast
              qed
            qed
            show "«?f : a'  a»  cones_map ?f ( a) = χ'"
              using f_in_hom f_map by simp
            show "f'. «f' : a'  a»  cones_map f' ( a) = χ'  f' = ?f"
            proof -
              fix f'
              assume f': "«f' : a'  a»  cones_map f' ( a) = χ'"
              have f'_in_hom: "«f' : a'  a»" using f' by simp
              have f'_map: "cones_map f' ( a) = χ'" using f' by simp
              show "f' = ?f"
              proof (intro S.arr_eqI' [of f' ?f])
                show "S.par f' ?f"
                  using f_in_hom f'_in_hom by (elim S.in_homE, auto)
                show "y'. «y' : S.unity  S.dom f'»  f'  y' = ?f  y'"
                proof -
                  fix y'
                  assume y': "«y' : S.unity  S.dom f'»"
                  have 0: "φ (f'  y') = cones_map y' χ'"
                  proof
                    fix j
                    have 1: "«f'  y' : S.unity  a»" using f'_in_hom y' by auto
                    hence 2: "φ (f'  y')  cones S.unity"
                      using φ bij_betw_imp_funcset [of φ "S.hom S.unity a" "cones S.unity"]
                      by auto
                    interpret χ'': cone J S D S.unity φ (f'  y') using 2 by auto
                    have "¬J.arr j  φ (f'  y') j = cones_map y' χ' j"
                      using f' y' cone_χ' χ''.is_extensional mem_Collect_eq restrict_apply
                      by (elim S.in_homE, auto)
                    moreover have "J.arr j  φ (f'  y') j = cones_map y' χ' j"
                    proof -
                      assume j: "J.arr j"
                      have 3: "« a j : a  D (J.cod j)»"
                        using j χa.preserves_hom by force
                      have "φ (f'  y') j = φ (a  f'  y') j"
                        using a f' y' j S.comp_cod_arr by (elim S.in_homE, auto)
                      also have "... =  a j  f'  y'"
                        using 1 3 χ [of a] a f' y' j by fastforce
                      also have "... = ( a j  f')  y'"
                        using S.comp_assoc by simp
                      also have "... = cones_map f' ( a) j  y'"
                        using f' y' j χa.cone_axioms by auto
                      also have "... = χ' j  y'"
                        using f' by blast
                      also have "... = cones_map y' χ' j"
                        using y' j cone_χ' f' mem_Collect_eq restrict_apply by force
                      finally show "φ (f'  y') j = cones_map y' χ' j" by auto
                    qed
                    ultimately show "φ (f'  y') j = cones_map y' χ' j" by auto
                  qed
                  hence "f'  y' =  (cones_map y' χ')"
                    using φ f'_in_hom y' S.comp_in_homI
                          bij_betw_inv_into_left [of φ "S.hom S.unity a" "cones S.unity" "f'  y'"]
                    by (elim S.in_homE, auto)
                  moreover have "?f  y' =  (cones_map y' χ')"
                    using φ 0 1 f f_in_hom f'_in_hom y' S.comp_in_homI
                          bij_betw_inv_into_left [of φ "S.hom S.unity a" "cones S.unity" "?f  y'"]
                    by (elim S.in_homE, auto)
                  ultimately show "f'  y' = ?f  y'" by auto
                qed
              qed
            qed
          qed
        qed
        have "limit_cone a ( a)" ..
        thus ?thesis by auto
      qed
    qed

  end

  locale diagram_in_replete_set_category =
    J: category J +
    S: replete_set_category S +
    diagram J S D
  for J :: "'j comp"      (infixr "J" 55)
  and S :: "'s comp"      (infixr "" 55)
  and D :: "'j  's"
  begin

    sublocale diagram_in_set_category J S ‹cardSuc (cmax (card_of (UNIV :: 's set)) natLeq) D
      ..

  end

  context set_category
  begin

    text‹
      A set category has an equalizer for any parallel pair of arrows.
›

    lemma has_equalizers:
    shows "has_equalizers"
    proof (unfold has_equalizers_def)
      have "f0 f1. par f0 f1  e. has_as_equalizer f0 f1 e"
      proof -
        fix f0 f1
        assume par: "par f0 f1"
        interpret J: parallel_pair .
        interpret PP: parallel_pair_diagram S f0 f1
          apply unfold_locales using par by auto
        interpret PP: diagram_in_set_category J.comp S 𝔄 PP.map ..
        text‹
          Let @{term a} be the object corresponding to the set of all images of equalizing points
          of @{term "dom f0"}, and let @{term e} be the inclusion of @{term a} in @{term "dom f0"}.
›
        let ?a = "mkIde (img ` {e. e  hom unity (dom f0)  f0  e = f1  e})"
        have 0: "{e. e  hom unity (dom f0)  f0  e = f1  e}  hom unity (dom f0)"
          by auto
        hence 1: "img ` {e. e  hom unity (dom f0)  f0  e = f1  e}  Univ"
          using img_point_in_Univ by auto
        have 2: "|img ` {e. e  hom unity (dom f0)  f0  e = f1  e}| <o 𝔄"
        proof -
          have "|hom unity (dom f0)| =o |Dom f0|"
            using par bij_betw_points_and_set [of "dom f0"]
            by (simp add: card_of_ordIsoI)
          moreover have "|Dom f0| <o 𝔄"
            using par set_card by simp
          ultimately have "|hom unity (dom f0)| <o 𝔄"
            using ordIso_ordLess_trans by blast
          moreover have
              "|{e. e  hom unity (dom f0)  f0  e = f1  e}| ≤o |hom unity (dom f0)|"
            using 0 by simp
          ultimately have "|{e. e  hom unity (dom f0)  f0  e = f1  e}| <o 𝔄"
            using ordLeq_ordLess_trans by blast
          thus ?thesis
            using card_of_image ordLeq_ordLess_trans by blast
        qed
        have ide_a: "ide ?a" using 1 2 ide_mkIde by auto
        have set_a: "set ?a = img ` {e. e  hom unity (dom f0)  f0  e = f1  e}"
          using 1 2 set_mkIde by simp
        have incl_in_a: "incl_in ?a (dom f0)"
        proof -
          have "ide (dom f0)"
            using PP.is_parallel by simp
          moreover have "set ?a  set (dom f0)"
          proof -
            have "set ?a = img ` {e. e  hom unity (dom f0)  f0  e = f1  e}"
              using img_point_in_Univ set_a by blast
            thus ?thesis
              using imageE img_point_elem_set mem_Collect_eq subsetI by auto
          qed
          ultimately show ?thesis
            using incl_in_def ‹ide ?a by simp
        qed
        text‹
          Then @{term "set a"} is in bijective correspondence with @{term "PP.cones unity"}.
›
        let  = "λt. PP.mkCone (mkPoint (dom f0) t)"
        let  = "λχ. img (χ (J.Zero))"
        have bij: "bij_betw  (set ?a) (PP.cones unity)"
        proof (intro bij_betwI)
          show "  set ?a  PP.cones unity"
          proof
            fix t
            assume t: "t  set ?a"
            hence 1: "t  img ` {e. e  hom unity (dom f0)  f0  e = f1  e}"
              using set_a by blast
            then have 2: "mkPoint (dom f0) t  hom unity (dom f0)"
              using mkPoint_in_hom imageE mem_Collect_eq mkPoint_img(2) by auto
            with 1 have 3: "mkPoint (dom f0) t  {e. e  hom unity (dom f0)  f0  e = f1  e}"
              using mkPoint_img(2) by auto
            then have "PP.is_equalized_by (mkPoint (dom f0) t)"
              using CollectD par by fastforce
            thus "PP.mkCone (mkPoint (dom f0) t)  PP.cones unity"
              using 2 PP.cone_mkCone [of "mkPoint (dom f0) t"] by auto
          qed
          show "  PP.cones unity  set ?a"
          proof
            fix χ
            assume χ: "χ  PP.cones unity"
            interpret χ: cone J.comp S PP.map unity χ using χ by auto
            have "χ (J.Zero)  hom unity (dom f0)  f0  χ (J.Zero) = f1  χ (J.Zero)"
              using χ PP.map_def PP.is_equalized_by_cone J.arr_char by auto
            hence "img (χ (J.Zero))  set ?a"
              using set_a by simp
            thus " χ  set ?a" by blast
          qed
          show "t. t  set ?a   ( t) = t"
            using set_a J.arr_char PP.mkCone_def imageE mem_Collect_eq mkPoint_img(2)
            by auto
          show "χ. χ  PP.cones unity   ( χ) = χ"
          proof -
            fix χ
            assume χ: "χ  PP.cones unity"
            interpret χ: cone J.comp S PP.map unity χ using χ by auto
            have 1: "χ (J.Zero)  hom unity (dom f0)  f0  χ (J.Zero) = f1  χ (J.Zero)"
              using χ PP.map_def PP.is_equalized_by_cone J.arr_char by auto
            hence "img (χ (J.Zero))  set ?a"
              using set_a by simp
            hence "img (χ (J.Zero))  set (dom f0)"
              using incl_in_a incl_in_def by auto
            hence "mkPoint (dom f0) (img (χ J.Zero)) = χ J.Zero"
              using 1 mkPoint_img(2) by blast
            hence " ( χ) = PP.mkCone (χ J.Zero)" by simp
            also have "... = χ"
              using χ PP.mkCone_cone by simp
            finally show " ( χ) = χ" by auto
          qed
        qed
        text‹
          It follows that @{term a} is a limit of PP›, and that the limit cone gives an
          equalizer of @{term f0} and @{term f1}.
›
        have "μ. bij_betw μ (hom unity ?a) (set ?a)"
          using bij_betw_points_and_set ide_a by auto
        from this obtain μ where μ: "bij_betw μ (hom unity ?a) (set ?a)" by blast
        have "bij_betw ( o μ) (hom unity ?a) (PP.cones unity)"
          using bij μ bij_betw_comp_iff by blast
        hence "φ. bij_betw φ (hom unity ?a) (PP.cones unity)" by auto
        hence "PP.has_as_limit ?a"
          using ide_a PP.limits_are_sets_of_cones by simp
        from this obtain ε where ε: "limit_cone J.comp S PP.map ?a ε" by auto
        interpret ε: limit_cone J.comp S PP.map ?a ε using ε by auto
        have "PP.mkCone (ε (J.Zero)) = ε"
          using ε PP.mkCone_cone ε.cone_axioms by simp
        moreover have "dom (ε (J.Zero)) = ?a"
          using J.ide_char ε.preserves_hom ε.A.map_def by simp
        ultimately have "PP.has_as_equalizer (ε J.Zero)"
          using ε by simp
        thus "e. has_as_equalizer f0 f1 e"
          using par has_as_equalizer_def by auto   
      qed
      thus "f0 f1. par f0 f1  (e. has_as_equalizer f0 f1 e)" by auto
    qed

  end

  sublocale set_category  category_with_equalizers S
    apply unfold_locales using has_equalizers by auto

  context set_category
  begin

    text‹
      The aim of the next results is to characterize the conditions under which a set
      category has products.  In a traditional development of category theory,
      one shows that the category \textbf{Set} of \emph{all} sets has all small
      (\emph{i.e.}~set-indexed) products.  In the present context we do not have a
      category of \emph{all} sets, but rather only a category of all sets with
      elements at a particular type.  Clearly, we cannot expect such a category
      to have products indexed by arbitrarily large sets.  The existence of
      @{term I}-indexed products in a set category @{term[source=true] S} implies that the universe
      S.Univ› of @{term[source=true] S} must be large enough to admit the formation of
      @{term I}-tuples of its elements.  Conversely, for a set category @{term[source=true] S}
      the ability to form @{term I}-tuples in @{term Univ} implies that
      @{term[source=true] S} has @{term I}-indexed products.  Below we make this precise by
      defining the notion of when a set category @{term[source=true] S}
      ``admits @{term I}-indexed tupling'' and we show that @{term[source=true] S}
      has @{term I}-indexed products if and only if it admits @{term I}-indexed tupling.

      The definition of ``@{term[source=true] S} admits @{term I}-indexed tupling'' says that
      there is an injective map, from the space of extensional functions from
      @{term I} to @{term Univ}, to @{term Univ}.  However for a convenient
      statement and proof of the desired result, the definition of extensional
      function from theory @{theory "HOL-Library.FuncSet"} needs to be modified.
      The theory @{theory "HOL-Library.FuncSet"} uses the definite, but arbitrarily chosen value
      @{term undefined} as the value to be assumed by an extensional function outside
      of its domain.  In the context of the set_category›, though, it is
      more natural to use S.unity›, which is guaranteed to be an element of the
      universe of @{term[source=true] S}, for this purpose.  Doing things that way makes it
      simpler to establish a bijective correspondence between cones over @{term D} with apex
      @{term unity} and the set of extensional functions @{term d} that map
      each arrow @{term j} of @{term J} to an element @{term "d j"} of @{term "set (D j)"}.
      Possibly it makes sense to go back and make this change in set_category›,
      but that would mean completely abandoning @{theory "HOL-Library.FuncSet"} and essentially
      introducing a duplicate version for use with set_category›.
      As a compromise, what I have done here is to locally redefine the few notions from
      @{theory "HOL-Library.FuncSet"} that I need in order to prove the next set of results.
      The redefined notions are primed to avoid confusion with the original versions.
›

    definition extensional'
    where "extensional' A  {f. x. x  A  f x = unity}"

    abbreviation PiE'
    where "PiE' A B  Pi A B  extensional' A"

    abbreviation restrict'
    where "restrict' f A  λx. if x  A then f x else unity"

    lemma extensional'I [intro]:
    assumes "x. x  A  f x = unity"
    shows "f  extensional' A"
      using assms extensional'_def by auto

    lemma extensional'_arb:
    assumes "f  extensional' A" and "x  A"
    shows "f x = unity"
      using assms extensional'_def by fast

    lemma extensional'_monotone:
    assumes "A  B"
    shows "extensional' A  extensional' B"
    proof
      fix f
      assume f: "f  extensional' A"
      have 1: "x. x  A  f x = unity" using f extensional'_def by fast
      hence "x. x  B  f x = unity" using assms by auto
      thus "f  extensional' B" using extensional'_def by blast
    qed

    lemma PiE'_mono: "(x. x  A  B x  C x)  PiE' A B  PiE' A C"
      by auto

  end

  locale discrete_diagram_in_replete_set_category =
    S: replete_set_category S +
    discrete_diagram J S D +
    diagram_in_replete_set_category J S D
  for J :: "'j comp"      (infixr "J" 55)
  and S :: "'s comp"      (infixr "" 55)
  and D :: "'j  's"
  begin

    text‹
      For @{term D} a discrete diagram in a set category, there is a bijective correspondence
      between cones over @{term D} with apex unity and the set of extensional functions @{term d}
      that map each arrow @{term j} of @{term[source=true] J} to an element of
      @{term "S.set (D j)"}.
›

    abbreviation I
    where "I  Collect J.arr"

    definition funToCone
    where "funToCone F  λj. if J.arr j then S.mkPoint (D j) (F j) else S.null"

    definition coneToFun
    where "coneToFun χ  λj. if J.arr j then S.img (χ j) else S.unity"

    lemma funToCone_mapsto:
    shows "funToCone  S.PiE' I (S.set o D)  cones S.unity"
    proof
      fix F
      assume F: "F  S.PiE' I (S.set o D)"
      interpret U: constant_functor J S S.unity
        apply unfold_locales using S.ide_unity by auto
      have 1: "S.ide (S.mkIde S.Univ)"
        using S.ide_mkIde by simp
      have "cone S.unity (funToCone F)"
      proof
        show "j. ¬J.arr j  funToCone F j = S.null"
          using funToCone_def by simp
        fix j
        assume j: "J.arr j"
        have "funToCone F j = S.mkPoint (D j) (F j)"
          using j funToCone_def by simp
        moreover have "...  S.hom S.unity (D j)"
          using F j is_discrete S.img_mkPoint(1) [of "D j"] by force
        ultimately have 2: "funToCone F j  S.hom S.unity (D j)" by auto
        show 3: "S.dom (funToCone F j) = U.map (J.dom j)"
          using 2 j U.map_simp by auto
        show 4: "S.cod (funToCone F j) = D (J.cod j)"
          using 2 j is_discrete by auto
        show "D j  funToCone F (J.dom j) = funToCone F j"
          using 2 j is_discrete S.comp_cod_arr by auto
        show "funToCone F (J.cod j)  (U.map j) = funToCone F j"
          using 3 j is_discrete U.map_simp S.arr_dom_iff_arr S.comp_arr_dom U.preserves_arr
          by (metis J.ide_char)
      qed
      thus "funToCone F  cones S.unity" by auto
    qed

    lemma coneToFun_mapsto:
    shows "coneToFun  cones S.unity  S.PiE' I (S.set o D)"
    proof
      fix χ
      assume χ: "χ  cones S.unity"
      interpret χ: cone J S D S.unity χ using χ by auto
      show "coneToFun χ  S.PiE' I (S.set o D)"
      proof
        show "coneToFun χ  Pi I (S.set o D)"
          using S.mkPoint_img(1) coneToFun_def is_discrete χ.component_in_hom
          by (simp add: S.img_point_elem_set restrict_apply')
        show "coneToFun χ  S.extensional' I"
        proof
          fix x
          show "x  I  coneToFun χ x = S.unity"
            using coneToFun_def by simp
        qed
      qed
    qed

    lemma funToCone_coneToFun:
    assumes "χ  cones S.unity"
    shows "funToCone (coneToFun χ) = χ"
    proof
      interpret χ: cone J S D S.unity χ using assms by auto
      fix j
      have "¬J.arr j  funToCone (coneToFun χ) j = χ j"
        using funToCone_def χ.is_extensional by simp
      moreover have "J.arr j  funToCone (coneToFun χ) j = χ j"
        using funToCone_def coneToFun_def S.mkPoint_img(2) is_discrete χ.component_in_hom
        by auto
      ultimately show "funToCone (coneToFun χ) j = χ j" by blast
    qed

    lemma coneToFun_funToCone:
    assumes "F  S.PiE' I (S.set o D)"
    shows "coneToFun (funToCone F) = F"
    proof
      fix i
      have "i  I  coneToFun (funToCone F) i = F i"
        using assms coneToFun_def S.extensional'_arb [of F I i] by auto
      moreover have "i  I  coneToFun (funToCone F) i = F i"
      proof -
        assume i: "i  I"
        have "coneToFun (funToCone F) i = S.img (funToCone F i)"
          using i coneToFun_def by simp
        also have "... = S.img (S.mkPoint (D i) (F i))"
          using i funToCone_def by auto
        also have "... = F i"
          using assms i is_discrete S.img_mkPoint(2) by force
        finally show "coneToFun (funToCone F) i = F i" by auto
      qed
      ultimately show "coneToFun (funToCone F) i = F i" by auto
    qed

    lemma bij_coneToFun:
    shows "bij_betw coneToFun (cones S.unity) (S.PiE' I (S.set o D))"
      using coneToFun_mapsto funToCone_mapsto funToCone_coneToFun coneToFun_funToCone
            bij_betwI
      by blast

    lemma bij_funToCone:
    shows "bij_betw funToCone (S.PiE' I (S.set o D)) (cones S.unity)"
      using coneToFun_mapsto funToCone_mapsto funToCone_coneToFun coneToFun_funToCone
            bij_betwI
      by blast
 
  end

  context replete_set_category
  begin

    text‹
      A set category admits @{term I}-indexed tupling if there is an injective map that takes
      each extensional function from @{term I} to @{term Univ} to an element of @{term Univ}.
›

    definition admits_tupling
    where "admits_tupling I  π. π  PiE' I (λ_. Univ)  Univ  inj_on π (PiE' I (λ_. Univ))"

    lemma admits_tupling_monotone:
    assumes "admits_tupling I" and "I'  I"
    shows "admits_tupling I'"
    proof -
      from assms(1) obtain π
      where π: "π  PiE' I (λ_. Univ)  Univ  inj_on π (PiE' I (λ_. Univ))"
        using admits_tupling_def by metis
      have "π  PiE' I' (λ_. Univ)  Univ"
      proof
        fix f
        assume f: "f  PiE' I' (λ_. Univ)"
        have "f  PiE' I (λ_. Univ)"
          using assms(2) f extensional'_def [of I'] terminal_unity extensional'_monotone by auto
        thus "π f  Univ" using π by auto
      qed
      moreover have "inj_on π (PiE' I' (λ_. Univ))"
      proof -
        have 1: "F A A'. inj_on F A  A'  A  inj_on F A'"
          using subset_inj_on by blast
        moreover have "PiE' I' (λ_. Univ)  PiE' I (λ_. Univ)"
          using assms(2) extensional'_def [of I'] terminal_unity by auto
        ultimately show ?thesis using π assms(2) by blast
      qed
      ultimately show ?thesis using admits_tupling_def by metis
    qed

    lemma has_products_iff_admits_tupling:
    fixes I :: "'i set"
    shows "has_products I  I  UNIV  admits_tupling I"
    proof
      text‹
        If @{term[source=true] S} has @{term I}-indexed products, then for every @{term I}-indexed
        discrete diagram @{term D} in @{term[source=true] S} there is an object @{term ΠD}
        of @{term[source=true] S} whose points are in bijective correspondence with the set of
        cones over @{term D} with apex @{term unity}.  In particular this is true for
        the diagram @{term D} that assigns to each element of @{term I} the
        ``universal object'' @{term "mkIde Univ"}.
›
      assume has_products: "has_products I"
      have I: "I  UNIV" using has_products has_products_def by auto
      interpret J: discrete_category I SOME x. x  I
        using I someI_ex [of "λx. x  I"] by (unfold_locales, auto)
      let ?D = "λi. mkIde Univ"
      interpret D: discrete_diagram_from_map I S ?D SOME j. j  I
        using J.not_arr_null J.arr_char ide_mkIde
        by (unfold_locales, auto)
      interpret D: discrete_diagram_in_replete_set_category J.comp S D.map ..
      have "discrete_diagram J.comp S D.map" ..
      from this obtain ΠD χ where χ: "product_cone J.comp S D.map ΠD χ"
        using has_products has_products_def [of I] ex_productE [of "J.comp" D.map]
              D.diagram_axioms
        by blast
      interpret χ: product_cone J.comp S D.map ΠD χ
        using χ by auto
      have "D.has_as_limit ΠD"
        using χ.limit_cone_axioms by auto
      hence ΠD: "ide ΠD  (φ. bij_betw φ (hom unity ΠD) (D.cones unity))"
        using D.limits_are_sets_of_cones by simp
      from this obtain φ where φ: "bij_betw φ (hom unity ΠD) (D.cones unity)"
        by blast
      have φ': "inv_into (hom unity ΠD) φ  D.cones unity  hom unity ΠD 
                inj_on (inv_into (hom unity ΠD) φ) (D.cones unity)"
        using φ bij_betw_inv_into bij_betw_imp_inj_on bij_betw_imp_funcset by blast
      let  = "img o (inv_into (hom unity ΠD) φ) o D.funToCone"
      have 1: "D.funToCone  PiE' I (set o D.map)  D.cones unity"
        using D.funToCone_mapsto extensional'_def [of I] by auto
      have 2: "inv_into (hom unity ΠD) φ  D.cones unity  hom unity ΠD"
        using φ' by auto
      have 3: "img  hom unity ΠD  Univ"
        using img_point_in_Univ by blast
      have 4: "inj_on D.funToCone (PiE' I (set o D.map))"
      proof -
        have "D.I = I" by auto
        thus ?thesis
          using D.bij_funToCone bij_betw_imp_inj_on by auto
      qed
      have 5: "inj_on (inv_into (hom unity ΠD) φ) (D.cones unity)"
        using φ' by auto
      have 6: "inj_on img (hom unity ΠD)"
        using ΠD bij_betw_points_and_set bij_betw_imp_inj_on [of img "hom unity ΠD" "set ΠD"]
        by simp
      have "  PiE' I (set o D.map)  Univ"
        using 1 2 3 by force
      moreover have "inj_on  (PiE' I (set o D.map))"
      proof -
        have 7: "A B C D F G H. F  A  B  G  B  C  H  C  D
                       inj_on F A  inj_on G B  inj_on H C
                     inj_on (H o G o F) A"
        proof (intro inj_onI)
          fix A :: "'a set" and B :: "'b set" and C :: "'c set" and D :: "'d set"
          and F :: "'a  'b" and G :: "'b  'c" and H :: "'c  'd"
          assume a1: "F  A  B  G  B  C  H  C  D 
                      inj_on F A  inj_on G B  inj_on H C"
          fix a a'
          assume a: "a  A" and a': "a'  A" and eq: "(H o G o F) a = (H o G o F) a'"
          have "H (G (F a)) = H (G (F a'))" using eq by simp
          moreover have "G (F a)  C  G (F a')  C" using a a' a1 by auto
          ultimately have "G (F a) = G (F a')" using a1 inj_onD by metis
          moreover have "F a  B  F a'  B" using a a' a1 by auto
          ultimately have "F a = F a'" using a1 inj_onD by metis
          thus "a = a'" using a a' a1 inj_onD by metis
        qed
        show ?thesis
          using 1 2 3 4 5 6 7 [of D.funToCone "PiE' I (set o D.map)" "D.cones unity"
                                  "inv_into (hom unity ΠD) φ" "hom unity ΠD"
                                  img Univ]
          by fastforce
      qed
      moreover have "PiE' I (set o D.map) = PiE' I (λx. Univ)"
      proof -
        have "i. i  I  (set o D.map) i = Univ"
          using J.arr_char D.map_def set_mkIde by simp
        thus ?thesis by blast
      qed
      ultimately have "  (PiE' I (λx. Univ))  Univ  inj_on  (PiE' I (λx. Univ))"
        by auto
      thus "I  UNIV  admits_tupling I"
        using I admits_tupling_def by auto
      next
      assume ex_π: "I  UNIV  admits_tupling I"
      show "has_products I"
      proof (unfold has_products_def)
        from ex_π obtain π
        where π: "π  (PiE' I (λx. Univ))  Univ  inj_on π (PiE' I (λx. Univ))"
          using admits_tupling_def by metis
        text‹
          Given an @{term I}-indexed discrete diagram @{term D}, obtain the object @{term ΠD}
          of @{term[source=true] S} corresponding to the set @{term "π ` PiE I D"} of all
          @{term "π d"} where d ∈ d ∈ J →E Univ› and @{term "d i  D i"}
          for all @{term "i  I"}.
          The elements of @{term ΠD} are in bijective correspondence with the set of cones
          over @{term D}, hence @{term ΠD} is a limit of @{term D}.
›
        have "J D. discrete_diagram J S D  Collect (partial_magma.arr J) = I
                  ΠD. has_as_product J D ΠD"
        proof
          fix J :: "'i comp" and D
          assume D: "discrete_diagram J S D  Collect (partial_magma.arr J) = I"
          interpret J: category J
            using D discrete_diagram.axioms(1) by blast
          interpret D: discrete_diagram J S D
            using D by simp
          interpret D: discrete_diagram_in_replete_set_category J S D ..
          let ?ΠD = "mkIde (π ` PiE' I (set o D))"
          have 0: "ide ?ΠD"
          proof -
            have "set o D  I  Pow Univ"
              using Pow_iff incl_in_def o_apply elem_set_implies_incl_in
                    set_subset_Univ subsetI
              by (metis (mono_tags, lifting) Pi_I')
            hence "π ` PiE' I (set o D)  Univ"
              using π by blast
            thus ?thesis using π ide_mkIde by simp
          qed
          hence set_ΠD: "π ` PiE' I (set o D) = set ?ΠD"
            using 0 ide_in_hom arr_mkIde set_mkIde by auto
          text‹
            The elements of @{term ΠD} are all values of the form @{term "π d"},
            where @{term d} satisfies @{term "d i  set (D i)"} for all @{term "i  I"}.
            Such @{term d} correspond bijectively to cones.
            Since @{term π} is injective, the values @{term "π d"} correspond bijectively to cones.
›
          let  = "mkPoint ?ΠD o π o D.coneToFun"
          let ?φ' = "D.funToCone o inv_into (PiE' I (set o D)) π o img"
          have 1: "π  PiE' I (set o D)  set ?ΠD  inj_on π (PiE' I (set o D))"
          proof -
            have "PiE' I (set o D)  PiE' I (λx. Univ)"
              using set_subset_Univ elem_set_implies_incl_in elem_set_implies_set_eq_singleton
                    incl_in_def PiE'_mono
              by (metis comp_apply subsetI)
            thus ?thesis using π subset_inj_on set_ΠD Pi_I' imageI by fastforce
          qed
          have 2: "inv_into (PiE' I (set o D)) π  set ?ΠD  PiE' I (set o D)"
          proof
            fix y
            assume y: "y  set ?ΠD"
            have "y  π ` (PiE' I (set o D))" using y set_ΠD by auto
            thus "inv_into (PiE' I (set o D)) π y  PiE' I (set o D)"
              using inv_into_into [of y π "PiE' I (set o D)"] by simp
          qed
          have 3: "x. x  set ?ΠD  π (inv_into (PiE' I (set o D)) π x) = x"
            using set_ΠD by (simp add: f_inv_into_f)
          have 4: "d. d  PiE' I (set o D)  inv_into (PiE' I (set o D)) π (π d) = d"
            using 1 by auto
          have 5: "D.I = I"
            using D by auto
          have "bij_betw  (D.cones unity) (hom unity ?ΠD)"
          proof (intro bij_betwI)
            show "  D.cones unity  hom unity ?ΠD"
            proof
              fix χ
              assume χ: "χ  D.cones unity"
              show " χ  hom unity ?ΠD"
                using χ 0 1 5 D.coneToFun_mapsto mkPoint_in_hom [of ?ΠD]
                by (simp, blast)
            qed
            show "?φ'  hom unity ?ΠD  D.cones unity"
            proof
              fix x
              assume x: "x  hom unity ?ΠD"
              hence "img x  set ?ΠD"
                using img_point_elem_set by blast
              hence "inv_into (PiE' I (set o D)) π (img x)  Pi I (set  D)  extensional' I"
                using 2 by blast
              thus "?φ' x  D.cones unity"
                using 5 D.funToCone_mapsto by auto
            qed
            show "x. x  hom unity ?ΠD   (?φ' x) = x"
            proof -
              fix x
              assume x: "x  hom unity ?ΠD"
              show " (?φ' x) = x"
              proof -
                have "D.coneToFun (D.funToCone (inv_into (PiE' I (set o D)) π (img x)))
                          = inv_into (PiE' I (set o D)) π (img x)"
                  using x 1 5 img_point_elem_set set_ΠD D.coneToFun_funToCone by force
                hence "π (D.coneToFun (D.funToCone (inv_into (PiE' I (set o D)) π (img x))))
                          = img x"
                  using x 3 img_point_elem_set set_ΠD by force
                thus ?thesis using x 0 mkPoint_img by auto
              qed
            qed
            show "χ. χ  D.cones unity  ?φ' ( χ) = χ"
            proof -
              fix χ
              assume χ: "χ  D.cones unity"
              show "?φ' ( χ) = χ"
              proof -
                have "img (mkPoint ?ΠD (π (D.coneToFun χ))) = π (D.coneToFun χ)"
                  using χ 0 1 5 D.coneToFun_mapsto img_mkPoint(2) by blast
                hence "inv_into (PiE' I (set o D)) π (img (mkPoint ?ΠD (π (D.coneToFun χ))))
                         = D.coneToFun χ"
                  using χ D.coneToFun_mapsto 4 5 by (metis PiE)
                hence "D.funToCone (inv_into (PiE' I (set o D)) π
                                             (img (mkPoint ?ΠD (π (D.coneToFun χ)))))
                         = χ"
                  using χ D.funToCone_coneToFun by auto
                thus ?thesis by auto
              qed
            qed
          qed
          hence "bij_betw (inv_into (D.cones unity) ) (hom unity ?ΠD) (D.cones unity)"
            using bij_betw_inv_into by blast
          hence "φ. bij_betw φ (hom unity ?ΠD) (D.cones unity)" by blast
          hence "D.has_as_limit ?ΠD"
            using ‹ide ?ΠD D.limits_are_sets_of_cones by simp
          from this obtain χ where χ: "limit_cone J S D ?ΠD χ" by blast
          interpret χ: limit_cone J S D ?ΠD χ using χ by auto
          interpret P: product_cone J S D ?ΠD χ
            using χ D.product_coneI by blast
          have "product_cone J S D ?ΠD χ" ..
          thus "has_as_product J D ?ΠD"
            using has_as_product_def by auto
        qed
        thus "I  UNIV 
              (J D. discrete_diagram J S D  Collect (partial_magma.arr J) = I
                   (ΠD. has_as_product J D ΠD))"
          using ex_π by blast
      qed
    qed

    text‹
      Characterization of the completeness properties enjoyed by a set category:
      A set category @{term[source=true] S} has all limits at a type @{typ 'j},
      if and only if @{term[source=true] S} admits @{term I}-indexed tupling
      for all @{typ 'j}-sets @{term I} such that @{term "I  UNIV"}.
›

    theorem has_limits_iff_admits_tupling:
    shows "has_limits (undefined :: 'j)  (I :: 'j set. I  UNIV  admits_tupling I)"
    proof
      assume has_limits: "has_limits (undefined :: 'j)"
      show "I :: 'j set. I  UNIV  admits_tupling I"
        using has_limits has_products_if_has_limits has_products_iff_admits_tupling by blast
      next
      assume admits_tupling: "I :: 'j set. I  UNIV  admits_tupling I"
      show "has_limits (undefined :: 'j)"
      proof -
        have 1: "I :: 'j set. I  UNIV  has_products I"
          using admits_tupling has_products_iff_admits_tupling by auto
        have "J :: 'j comp. category J  has_products (Collect (partial_magma.arr J))"
        proof -
          fix J :: "'j comp"
          assume J: "category J"
          interpret J: category J using J by auto
          have "Collect J.arr  UNIV" using J.not_arr_null by blast
          thus "has_products (Collect J.arr)"
            using 1 by simp
        qed
        hence "J :: 'j comp. category J  has_limits_of_shape J"
        proof -
          fix J :: "'j comp"
          assume J: "category J"
          interpret J: category J using J by auto
          show "has_limits_of_shape J"
          proof -
            have "Collect J.arr  UNIV" using J.not_arr_null by fast
            moreover have "Collect J.ide  UNIV" using J.not_arr_null by blast
            ultimately show ?thesis
              using 1 has_limits_if_has_products J.category_axioms by metis
          qed
        qed
        thus "has_limits (undefined :: 'j)"
          using has_limits_def by metis
      qed
    qed

  end

  section "Limits in Functor Categories"

  text‹
    In this section, we consider the special case of limits in functor categories,
    with the objective of showing that limits in a functor category [A, B]›
    are given pointwise, and that [A, B]› has all limits that @{term B} has.
›

  locale parametrized_diagram =
    J: category J +
    A: category A +
    B: category B +
    JxA: product_category J A +
    binary_functor J A B D
  for J :: "'j comp"      (infixr "J" 55)
  and A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and D :: "'j * 'a  'b"
  begin

    (* Notation for A.in_hom and B.in_hom is being inherited, but from where? *)
    notation J.in_hom     ("«_ : _ J _»")
    notation JxA.comp     (infixr "JxA" 55)
    notation JxA.in_hom   ("«_ : _ JxA _»")

    text‹
      A choice of limit cone for each diagram D (-, a)›, where @{term a}
      is an object of @{term[source=true] A}, extends to a functor L: A → B›,
      where the action of @{term L} on arrows of @{term[source=true] A} is determined by
      universality.
›

    abbreviation L
    where "L  λl χ. λa. if A.arr a then
                            limit_cone.induced_arrow J B (λj. D (j, A.cod a))
                              (l (A.cod a)) (χ (A.cod a))
                              (l (A.dom a)) (vertical_composite.map J B
                                               (χ (A.dom a)) (λj. D (j, a)))
                          else B.null"

    abbreviation P
    where "P  λl χ. λa f. «f : l (A.dom a) B l (A.cod a)» 
                           diagram.cones_map J B (λj. D (j, A.cod a)) f (χ (A.cod a)) =
                           vertical_composite.map J B (χ (A.dom a)) (λj. D (j, a))"

    lemma L_arr:
    assumes "a. A.ide a  limit_cone J B (λj. D (j, a)) (l a) (χ a)"
    shows "a. A.arr a  (∃!f. P l χ a f)  P l χ a (L l χ a)"
    proof
      fix a
      assume a: "A.arr a"
      interpret χ_dom_a: limit_cone J B λj. D (j, A.dom a) l (A.dom a) χ (A.dom a)
        using a assms by auto
      interpret χ_cod_a: limit_cone J B λj. D (j, A.cod a) l (A.cod a) χ (A.cod a)
        using a assms by auto
      interpret Da: natural_transformation J B λj. D (j, A.dom a) λj. D (j, A.cod a)
                                               λj. D (j, a)
        using a fixing_arr_gives_natural_transformation_2 by simp
      interpret Daoχ_dom_a: vertical_composite J B
                              χ_dom_a.A.map λj. D (j, A.dom a) λj. D (j, A.cod a)
                              χ (A.dom a) λj. D (j, a) ..
      interpret Daoχ_dom_a: cone J B λj. D (j, A.cod a) l (A.dom a) Daoχ_dom_a.map ..
      show "P l χ a (L l χ a)"
        using a Daoχ_dom_a.cone_axioms χ_cod_a.induced_arrowI [of Daoχ_dom_a.map "l (A.dom a)"]
        by auto
      show "∃!f. P l χ a f"
        using χ_cod_a.is_universal Daoχ_dom_a.cone_axioms by blast
    qed

    lemma L_ide:
    assumes "a. A.ide a  limit_cone J B (λj. D (j, a)) (l a) (χ a)"
    shows "a. A.ide a  L l χ a = l a"
    proof -
      let ?L = "L l χ"
      let ?P = "P l χ"
      fix a
      assume a: "A.ide a"
      interpret χa: limit_cone J B λj. D (j, a) l a χ a using a assms by auto
      have Pa: "?P a = (λf. f  B.hom (l a) (l a) 
                            diagram.cones_map J B (λj. D (j, a)) f (χ a) = χ a)"
        using a vcomp_ide_dom χa.natural_transformation_axioms by simp
      have "?P a (?L a)" using assms a L_arr [of l χ a] by fastforce
      moreover have "?P a (l a)"
      proof -
        have "?P a (l a)  l a  B.hom (l a) (l a)  χa.D.cones_map (l a) (χ a) = χ a"
          using Pa by meson
        thus ?thesis
          using a χa.ide_apex χa.cone_axioms χa.D.cones_map_ide [of "χ a" "l a"] by force
      qed
      moreover have "∃!f. ?P a f"
        using a Pa χa.is_universal χa.cone_axioms by force
      ultimately show "?L a = l a" by blast
    qed

    lemma chosen_limits_induce_functor:
    assumes "a. A.ide a  limit_cone J B (λj. D (j, a)) (l a) (χ a)"
    shows "functor A B (L l χ)"
    proof -
      let ?L = "L l χ"
      let ?P = "λa. λf. «f : l (A.dom a) B l (A.cod a)» 
                        diagram.cones_map J B (λj. D (j, A.cod a)) f (χ (A.cod a))
                             = vertical_composite.map J B (χ (A.dom a)) (λj. D (j, a))"
      interpret L: "functor" A B ?L
        apply unfold_locales
        using assms L_arr [of l] L_ide
            apply auto[4]
      proof -
        fix a' a
        assume 1: "A.arr (A a' a)"
        have a: "A.arr a" using 1 by auto
        have a': "«a' : A.cod a A A.cod a'»" using 1 by auto
        have a'a: "A.seq a' a" using 1 by auto
        interpret χ_dom_a: limit_cone J B λj. D (j, A.dom a) l (A.dom a) χ (A.dom a)
          using a assms by auto
        interpret χ_cod_a: limit_cone J B λj. D (j, A.cod a) l (A.cod a) χ (A.cod a)
          using a'a assms by auto
        interpret χ_dom_a'a: limit_cone J B λj. D (j, A.dom (a' A a)) l (A.dom (a' A a))
                                            χ (A.dom (a' A a))
          using a'a assms by auto
        interpret χ_cod_a'a: limit_cone J B λj. D (j, A.cod (a' A a)) l (A.cod (a' A a))
                                            χ (A.cod (a' A a))
          using a'a assms by auto
        interpret Da: natural_transformation J B
                         λj. D (j, A.dom a) λj. D (j, A.cod a) λj. D (j, a)
          using a fixing_arr_gives_natural_transformation_2 by simp
        interpret Da': natural_transformation J B
                         λj. D (j, A.cod a) λj. D (j, A.cod (a' A a)) λj. D (j, a')
          using a a'a fixing_arr_gives_natural_transformation_2 by fastforce
        interpret Da'oχ_cod_a: vertical_composite J B
                                 χ_cod_a.A.map λj. D (j, A.cod a) λj. D (j, A.cod (a' A a))
                                 χ (A.cod a) λj. D (j, a')..
        interpret Da'oχ_cod_a: cone J B λj. D (j, A.cod (a' A a)) l (A.cod a) Da'oχ_cod_a.map
          ..
        interpret Da'a: natural_transformation J B
                          λj. D (j, A.dom (a' A a)) λj. D (j, A.cod (a' A a))
                          λj. D (j, a' A a)
          using a'a fixing_arr_gives_natural_transformation_2 [of "a' A a"] by auto
        interpret Da'aoχ_dom_a'a:
            vertical_composite J B χ_dom_a'a.A.map λj. D (j, A.dom (a' A a))
                                   λj. D (j, A.cod (a' A a)) χ (A.dom (a' A a))
                                   λj. D (j, a' A a) ..
        interpret Da'aoχ_dom_a'a: cone J B λj. D (j, A.cod (a' A a))
                                       l (A.dom (a' A a)) Da'aoχ_dom_a'a.map ..
        show "?L (a' A a) = ?L a' B ?L a"
        proof -
          have "?P (a' A a) (?L (a' A a))" using assms a'a L_arr [of l χ "a' A a"] by fastforce
          moreover have "?P (a' A a) (?L a' B ?L a)"
          proof
            have La: "«?L a : l (A.dom a) B l (A.cod a)»"
              using assms a L_arr by fast
            moreover have La': "«?L a' : l (A.cod a) B l (A.cod a')»"
              using assms a a' L_arr [of l χ a'] by auto
            ultimately have seq: "B.seq (?L a') (?L a)" by (elim B.in_homE, auto)
            thus La'_La: "«?L a' B ?L a : l (A.dom (a' A a)) B l (A.cod (a' A a))»"
              using a a' 1 La La' by (intro B.comp_in_homI, auto)
            show "χ_cod_a'a.D.cones_map (?L a' B ?L a) (χ (A.cod (a' A a)))
                    = Da'aoχ_dom_a'a.map"
            proof -
              have "χ_cod_a'a.D.cones_map (?L a' B ?L a) (χ (A.cod (a' A a)))
                       = (χ_cod_a'a.D.cones_map (?L a) o χ_cod_a'a.D.cones_map (?L a'))
                           (χ (A.cod a'))"
              proof -
                have "χ_cod_a'a.D.cones_map (?L a' B ?L a) (χ (A.cod (a' A a))) =
                      restrict (χ_cod_a'a.D.cones_map (?L a)  χ_cod_a'a.D.cones_map (?L a'))
                               (χ_cod_a'a.D.cones (B.cod (?L a')))
                               (χ (A.cod (a' A a)))"
                  using seq χ_cod_a'a.cone_axioms χ_cod_a'a.D.cones_map_comp [of "?L a'" "?L a"]
                  by argo
                also have "... = (χ_cod_a'a.D.cones_map (?L a) o χ_cod_a'a.D.cones_map (?L a'))
                                 (χ (A.cod a'))"
                proof -
                  have "χ (A.cod a')  χ_cod_a'a.D.cones (l (A.cod a'))"
                    using χ_cod_a'a.cone_axioms a'a by simp
                  moreover have "B.cod (?L a') = l (A.cod a')"
                    using assms a' L_arr [of l] by auto
                  ultimately show ?thesis
                    using a' a'a by simp
                qed
                finally show ?thesis by blast
              qed
              also have "... = χ_cod_a'a.D.cones_map (?L a)
                                   (χ_cod_a'a.D.cones_map (?L a') (χ (A.cod a')))"
                  by simp
              also have "... = χ_cod_a'a.D.cones_map (?L a) Da'oχ_cod_a.map"
              proof -
                have "?P a' (?L a')" using assms a' L_arr [of l χ a'] by fast
                moreover have
                    "?P a' = (λf. f  B.hom (l (A.cod a)) (l (A.cod a')) 
                                  χ_cod_a'a.D.cones_map f (χ (A.cod a')) = Da'oχ_cod_a.map)"
                  using a'a by force
                ultimately show ?thesis using a'a by force
              qed
              also have "... = vertical_composite.map J B
                                 (χ_cod_a.D.cones_map (?L a) (χ (A.cod a)))
                                 (λj. D (j, a'))"
                using assms χ_cod_a.D.diagram_axioms χ_cod_a'a.D.diagram_axioms
                      Da'.natural_transformation_axioms χ_cod_a.cone_axioms La
                      cones_map_vcomp [of J B "λj. D (j, A.cod a)" "λj. D (j, A.cod (a' A a))"
                                          "λj. D (j, a')" "l (A.cod a)" "χ (A.cod a)"
                                          "?L a" "l (A.dom a)"]
                by blast
              also have "... = vertical_composite.map J B
                                 (vertical_composite.map J B (χ (A.dom a)) (λj. D (j, a)))
                                 (λj. D (j, a'))"
                using assms a L_arr by presburger
              also have "... = vertical_composite.map J B (χ (A.dom a))
                                 (vertical_composite.map J B (λj. D (j, a)) (λj. D (j, a')))"
                using a'a Da.natural_transformation_axioms Da'.natural_transformation_axioms
                      χ_dom_a.natural_transformation_axioms vcomp_assoc
                by auto
              also have
                  "... = vertical_composite.map J B (χ (A.dom (a' A a))) (λj. D (j, a' A a))"
                using a'a preserves_comp_2 by simp
              finally show ?thesis by auto
            qed
          qed
          moreover have "∃!f. ?P (a' A a) f"
            using χ_cod_a'a.is_universal
                    [of "l (A.dom (a' A a))"
                        "vertical_composite.map J B (χ (A.dom (a' A a))) (λj. D (j, a' A a))"]
                  Da'aoχ_dom_a'a.cone_axioms
            by fast
          ultimately show ?thesis by blast
        qed
      qed
      show ?thesis ..
    qed

  end

  locale diagram_in_functor_category =
    A: category A +
    B: category B +
    A_B: functor_category A B +
    diagram J A_B.comp D
  for A :: "'a comp"      (infixr "A" 55)
  and B :: "'b comp"      (infixr "B" 55)
  and J :: "'j comp"      (infixr "J" 55)
  and D :: "'j  ('a, 'b) functor_category.arr"
  begin

    interpretation JxA: product_category J A ..
    interpretation A_BxA: product_category A_B.comp A ..
    interpretation E: evaluation_functor A B ..
    interpretation Curry: currying J A B ..

    notation JxA.comp     (infixr "JxA" 55)
    notation JxA.in_hom   ("«_ : _ JxA _»")

    text‹
      Evaluation of a functor or natural transformation from @{term[source=true] J}
      to [A, B]› at an arrow @{term a} of @{term[source=true] A}.
›

    abbreviation at
    where "at a τ  λj. Curry.uncurry τ (j, a)"

    lemma at_simp:
    assumes "A.arr a" and "J.arr j" and "A_B.arr (τ j)"
    shows "at a τ j = A_B.Map (τ j) a"
      using assms Curry.uncurry_def E.map_simp by simp

    lemma functor_at_ide_is_functor:
    assumes "functor J A_B.comp F" and "A.ide a"
    shows "functor J B (at a F)"
    proof -
      interpret uncurry_F: "functor" JxA.comp B ‹Curry.uncurry F
        using assms(1) Curry.uncurry_preserves_functors by simp
      interpret uncurry_F: binary_functor J A B ‹Curry.uncurry F ..
      show ?thesis using assms(2) uncurry_F.fixing_ide_gives_functor_2 by simp
    qed

    lemma functor_at_arr_is_transformation:
    assumes "functor J A_B.comp F" and "A.arr a"
    shows "natural_transformation J B (at (A.dom a) F) (at (A.cod a) F) (at a F)"
    proof -
      interpret uncurry_F: "functor" JxA.comp B ‹Curry.uncurry F
        using assms(1) Curry.uncurry_preserves_functors by simp
      interpret uncurry_F: binary_functor J A B ‹Curry.uncurry F ..
      show ?thesis
        using assms(2) uncurry_F.fixing_arr_gives_natural_transformation_2 by simp
    qed

    lemma transformation_at_ide_is_transformation:
    assumes "natural_transformation J A_B.comp F G τ" and "A.ide a"
    shows "natural_transformation J B (at a F) (at a G) (at a τ)"
    proof -
      interpret τ: natural_transformation J A_B.comp F G τ using assms(1) by auto
      interpret uncurry_F: "functor" JxA.comp B ‹Curry.uncurry F
        using Curry.uncurry_preserves_functors τ.F.functor_axioms by simp
      interpret uncurry_f: binary_functor J A B ‹Curry.uncurry F ..
      interpret uncurry_G: "functor" JxA.comp B ‹Curry.uncurry G
        using Curry.uncurry_preserves_functors τ.G.functor_axioms by simp
      interpret uncurry_G: binary_functor J A B ‹Curry.uncurry G ..
      interpret uncurry_τ: natural_transformation
                             JxA.comp B ‹Curry.uncurry F ‹Curry.uncurry G ‹Curry.uncurry τ
        using Curry.uncurry_preserves_transformations τ.natural_transformation_axioms
        by simp
      interpret uncurry_τ: binary_functor_transformation J A B
                            ‹Curry.uncurry F ‹Curry.uncurry G ‹Curry.uncurry τ ..
      show ?thesis
        using assms(2) uncurry_τ.fixing_ide_gives_natural_transformation_2 by simp
    qed

    lemma constant_at_ide_is_constant:
    assumes "cone x χ" and a: "A.ide a"
    shows "at a (constant_functor.map J A_B.comp x) =
           constant_functor.map J B (A_B.Map x a)"
    proof -
      interpret χ: cone J A_B.comp D x χ using assms(1) by auto
      have x: "A_B.ide x" using χ.ide_apex by auto
      interpret Fun_x: "functor" A B ‹A_B.Map x
        using x A_B.ide_char by simp
      interpret Da: "functor" J B ‹at a D
        using a functor_at_ide_is_functor functor_axioms by blast
      interpret Da: diagram J B ‹at a D ..
      interpret Xa: constant_functor J B ‹A_B.Map x a
        using a Fun_x.preserves_ide by unfold_locales simp
      show "at a χ.A.map = Xa.map"
        using a x Curry.uncurry_def E.map_def Xa.is_extensional by auto
    qed

    lemma at_ide_is_diagram:
    assumes a: "A.ide a"
    shows "diagram J B (at a D)"
    proof -
      interpret Da: "functor" J B "at a D"
        using a functor_at_ide_is_functor functor_axioms by simp
      show ?thesis ..
    qed

    lemma cone_at_ide_is_cone:
    assumes "cone x χ" and a: "A.ide a"
    shows "diagram.cone J B (at a D) (A_B.Map x a) (at a χ)"
    proof -
      interpret χ: cone J A_B.comp D x χ using assms(1) by auto
      have x: "A_B.ide x" using χ.ide_apex by auto
      interpret Fun_x: "functor" A B ‹A_B.Map x
        using x A_B.ide_char by simp
      interpret Da: diagram J B ‹at a D using a at_ide_is_diagram by auto
      interpret Xa: constant_functor J B ‹A_B.Map x a
        using a by (unfold_locales, simp)
      interpret χa: natural_transformation J B Xa.map ‹at a D ‹at a χ
        using assms(1) x a transformation_at_ide_is_transformation χ.natural_transformation_axioms
              constant_at_ide_is_constant
        by fastforce
      interpret χa: cone J B ‹at a D ‹A_B.Map x a ‹at a χ ..
      show cone_χa: "Da.cone (A_B.Map x a) (at a χ)" ..
    qed

    lemma at_preserves_comp:
    assumes "A.seq a' a"
    shows "at (A a' a) D = vertical_composite.map J B (at a D) (at a' D)"
    proof -
      interpret Da: natural_transformation J B ‹at (A.dom a) D ‹at (A.cod a) D ‹at a D
        using assms functor_at_arr_is_transformation functor_axioms by blast
      interpret Da': natural_transformation J B ‹at (A.cod a) D ‹at (A.cod a') D ‹at a' D
        using assms functor_at_arr_is_transformation [of D a'] functor_axioms by fastforce
      interpret Da'oDa: vertical_composite J B
                          ‹at (A.dom a) D ‹at (A.cod a) D ‹at (A.cod a') D
                          ‹at a D ‹at a' D ..
      interpret Da'a: natural_transformation J B ‹at (A.dom a) D ‹at (A.cod a') D
                          ‹at (a' A a) D
        using assms functor_at_arr_is_transformation [of D "a' A a"] functor_axioms by simp
      show "at (a' A a) D = Da'oDa.map"
      proof (intro NaturalTransformation.eqI)
        show "natural_transformation J B (at (A.dom a) D) (at (A.cod a') D) Da'oDa.map" ..
        show "natural_transformation J B (at (A.dom a) D) (at (A.cod a') D) (at (a' A a) D)" ..
        show "j. J.ide j  at (a' A a) D j = Da'oDa.map j"
        proof -
          fix j
          assume j: "J.ide j"
          interpret Dj: "functor" A B ‹A_B.Map (D j)
            using j preserves_ide A_B.ide_char by simp
          show "at (a' A a) D j = Da'oDa.map j"
            using assms j Dj.preserves_comp at_simp Da'oDa.map_simp_ide by auto
        qed
      qed
    qed

    lemma cones_map_pointwise:
    assumes "cone x χ" and "cone x' χ'"
    and f: "f  A_B.hom x' x"
    shows "cones_map f χ = χ' 
             (a. A.ide a  diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ')"
    proof
      interpret χ: cone J A_B.comp D x χ using assms(1) by auto
      interpret χ': cone J A_B.comp D x' χ' using assms(2) by auto
      have x: "A_B.ide x" using χ.ide_apex by auto
      have x': "A_B.ide x'" using χ'.ide_apex by auto
      interpret χf: cone J A_B.comp D x' ‹cones_map f χ
        using x' f assms(1) cones_map_mapsto by blast
      interpret Fun_x: "functor" A B ‹A_B.Map x using x A_B.ide_char by simp
      interpret Fun_x': "functor" A B ‹A_B.Map x' using x' A_B.ide_char by simp
      show "cones_map f χ = χ' 
              (a. A.ide a  diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ')"
      proof -
        assume χ': "cones_map f χ = χ'"
        have "a. A.ide a  diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ'"
        proof -
          fix a
          assume a: "A.ide a"
          interpret Da: diagram J B ‹at a D using a at_ide_is_diagram by auto
          interpret χa: cone J B ‹at a D ‹A_B.Map x a ‹at a χ
            using a assms(1) cone_at_ide_is_cone by simp
          interpret χ'a: cone J B ‹at a D ‹A_B.Map x' a ‹at a χ'
            using a assms(2) cone_at_ide_is_cone by simp
          have 1: "«A_B.Map f a : A_B.Map x' a B A_B.Map x a»"
            using f a A_B.arr_char A_B.Map_cod A_B.Map_dom mem_Collect_eq
                  natural_transformation.preserves_hom A.ide_in_hom
            by (metis (no_types, lifting) A_B.in_homE)
          interpret χfa: cone J B ‹at a D ‹A_B.Map x' a
                           ‹Da.cones_map (A_B.Map f a) (at a χ)
            using 1 χa.cone_axioms Da.cones_map_mapsto by force
          show "Da.cones_map (A_B.Map f a) (at a χ) = at a χ'"
          proof
            fix j
            have "¬J.arr j  Da.cones_map (A_B.Map f a) (at a χ) j = at a χ' j"
              using χ'a.is_extensional χfa.is_extensional [of j] by simp
            moreover have "J.arr j  Da.cones_map (A_B.Map f a) (at a χ) j = at a χ' j"
              using a f 1 χ.cone_axioms χa.cone_axioms at_simp
              apply simp
              apply (elim A_B.in_homE B.in_homE, auto)
              using χ' χ.A.map_simp A_B.Map_comp [of "χ j" f a a] by auto
            ultimately show "Da.cones_map (A_B.Map f a) (at a χ) j = at a χ' j" by blast
          qed
        qed
        thus "a. A.ide a  diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ'"
          by simp
      qed
      show "a. A.ide a  diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ'
               cones_map f χ = χ'"
      proof -
        assume A:
            "a. A.ide a  diagram.cones_map J B (at a D) (A_B.Map f a) (at a χ) = at a χ'"
        show "cones_map f χ = χ'"
        proof (intro NaturalTransformation.eqI)
          show "natural_transformation J A_B.comp χ'.A.map D (cones_map f χ)" ..
          show "natural_transformation J A_B.comp χ'.A.map D χ'" ..
          show "j. J.ide j  cones_map f χ j = χ' j"
          proof (intro A_B.arr_eqI)
            fix j
            assume j: "J.ide j"
            show 1: "A_B.arr (cones_map f χ j)"
              using j χf.preserves_reflects_arr by simp
            show "A_B.arr (χ' j)" using j by auto
            have Dom_χf_j: "A_B.Dom (cones_map f χ j) = A_B.Map x'"
              using x' j 1 A_B.Map_dom χ'.A.map_simp χf.preserves_dom J.ide_in_hom
              by (metis (no_types, lifting) J.ideD(2) χf.preserves_reflects_arr)
            also have Dom_χ'_j: "... = A_B.Dom (χ' j)"
              using x' j A_B.Map_dom [of "χ' j"] χ'.preserves_hom χ'.A.map_simp by simp
            finally show "A_B.Dom (cones_map f χ j) = A_B.Dom (χ' j)" by auto
            have Cod_χf_j: "A_B.Cod (cones_map f χ j) = A_B.Map (D (J.cod j))"
              using j A_B.Map_cod A_B.cod_char J.ide_in_hom χf.preserves_hom
              by (metis (no_types, lifting) "1" J.ideD(1) χf.preserves_cod)
            also have Cod_χ'_j: "... = A_B.Cod (χ' j)"
              using j A_B.Map_cod [of "χ' j"] χ'.preserves_hom by simp
            finally show "A_B.Cod (cones_map f χ j) = A_B.Cod (χ' j)" by auto
            show "A_B.Map (cones_map f χ j) = A_B.Map (χ' j)"
            proof (intro NaturalTransformation.eqI)
              interpret χfj: natural_transformation A B ‹A_B.Map x' ‹A_B.Map (D (J.cod j))
                                                    ‹A_B.Map (cones_map f χ j)
                using j χf.preserves_reflects_arr A_B.arr_char [of "cones_map f χ j"]
                      Dom_χf_j Cod_χf_j
                by simp
              show "natural_transformation A B (A_B.Map x') (A_B.Map (D (J.cod j)))
                                           (A_B.Map (cones_map f χ j))" ..
              interpret χ'j: natural_transformation A B ‹A_B.Map x' ‹A_B.Map (D (J.cod j))
                                                   ‹A_B.Map (χ' j)
                using j A_B.arr_char [of "χ' j"] Dom_χ'_j Cod_χ'_j by simp
              show "natural_transformation A B (A_B.Map x') (A_B.Map (D (J.cod j)))
                                           (A_B.Map (χ' j))" ..
              show "a. A.ide a  A_B.Map (cones_map f χ j) a = A_B.Map (χ' j) a"
              proof -
                fix a
                assume a: "A.ide a"
                interpret Da: diagram J B ‹at a D using a at_ide_is_diagram by auto
                have cone_χa: "Da.cone (A_B.Map x a) (at a χ)"
                  using a assms(1) cone_at_ide_is_cone by simp
                interpret χa: cone J B ‹at a D ‹A_B.Map x a ‹at a χ
                  using cone_χa by auto
                interpret Fun_f: natural_transformation A B ‹A_B.Dom f ‹A_B.Cod f
                                   ‹A_B.Map f
                  using f A_B.arr_char by fast
                have fa: "A_B.Map f a  B.hom (A_B.Map x' a) (A_B.Map x a)"
                  using a f Fun_f.preserves_hom A.ide_in_hom by auto
                have "A_B.Map (cones_map f χ j) a = Da.cones_map (A_B.Map f a) (at a χ) j"
                proof -
                  have "A_B.Map (cones_map f χ j) a = A_B.Map (A_B.comp (χ j) f) a"
                    using assms(1) f χ.is_extensional by auto
                  also have "... = B (A_B.Map (χ j) a) (A_B.Map f a)"
                    using f j a χ.preserves_hom A.ide_in_hom J.ide_in_hom A_B.Map_comp
                          χ.A.map_simp
                    by (metis (no_types, lifting) A.comp_ide_self A.ideD(1) A_B.seqI'
                        J.ideD(1) mem_Collect_eq)
                  also have "... = Da.cones_map (A_B.Map f a) (at a χ) j"
                    using j a cone_χa fa Curry.uncurry_def E.map_simp by auto
                  finally show ?thesis by auto
                qed
                also have "... = at a χ' j" using j a A by simp
                also have "... = A_B.Map (χ' j) a"
                  using j Curry.uncurry_def E.map_simp χ'j.is_extensional by simp
                finally show "A_B.Map (cones_map f χ j) a = A_B.Map (χ' j) a" by auto
              qed
            qed
          qed
        qed
      qed
    qed
       
    text‹
      If @{term χ} is a cone with apex @{term a} over @{term D}, then @{term χ}
      is a limit cone if, for each object @{term x} of @{term X}, the cone obtained
      by evaluating @{term χ} at @{term x} is a limit cone with apex @{term "A_B.Map a x"}
      for the diagram in @{term C} obtained by evaluating @{term D} at @{term x}.
›

    lemma cone_is_limit_if_pointwise_limit:
    assumes cone_χ: "cone x χ"
    and "a. A.ide a  diagram.limit_cone J B (at a D) (A_B.Map x a) (at a χ)"
    shows "limit_cone x χ"
    proof -
      interpret χ: cone J A_B.comp D x χ using assms by auto
      have x: "A_B.ide x" using χ.ide_apex by auto
      show "limit_cone x χ"
      proof
        fix x' χ'
        assume cone_χ': "cone x' χ'"
        interpret χ': cone J A_B.comp D x' χ' using cone_χ' by auto
        have x': "A_B.ide x'" using χ'.ide_apex by auto
        text‹
          The universality of the limit cone at a χ› yields, for each object
          a› of A›, a unique arrow fa› that transforms
          at a χ› to at a χ'›.
›
        have EU: "a. A.ide a 
                        ∃!fa. fa  B.hom (A_B.Map x' a) (A_B.Map x a) 
                                   diagram.cones_map J B (at a D) fa (at a χ) = at a χ'"
        proof -
          fix a
          assume a: "A.ide a"
          interpret Da: diagram J B ‹at a D using a at_ide_is_diagram by auto
          interpret χa: limit_cone J B ‹at a D ‹A_B.Map x a ‹at a χ
            using assms(2) a by auto
          interpret χ'a: cone J B ‹at a D ‹A_B.Map x' a ‹at a χ'
            using a cone_χ' cone_at_ide_is_cone by auto
          have "Da.cone (A_B.Map x' a) (at a χ')" ..
          thus "∃!fa. fa  B.hom (A_B.Map x' a) (A_B.Map x a) 
                      Da.cones_map fa (at a χ) = at a χ'"
            using χa.is_universal by simp
        qed
        text‹
          Our objective is to show the existence of a unique arrow f› that transforms
          χ› into χ'›.  We obtain f› by bundling the arrows fa›
          of C› and proving that this yields a natural transformation from X›
          to C›, hence an arrow of [X, C]›.
›
        show "∃!f. «f : x' [A,B] x»  cones_map f χ = χ'"
        proof
          let ?P = "λa fa. «fa : A_B.Map x' a B A_B.Map x a» 
                           diagram.cones_map J B (at a D) fa (at a χ) = at a χ'"
          have AaPa: "a. A.ide a  ?P a (THE fa. ?P a fa)"
          proof -
            fix a
            assume a: "A.ide a"
            have "∃!fa. ?P a fa" using a EU by simp
            thus "?P a (THE fa. ?P a fa)" using a theI' [of "?P a"] by fastforce
          qed
          have AaPa_in_hom:
              "a. A.ide a  «THE fa. ?P a fa : A_B.Map x' a B A_B.Map x a»"
            using AaPa by blast
          have AaPa_map:
                  "a. A.ide a 
                       diagram.cones_map J B (at a D) (THE fa. ?P a fa) (at a χ) = at a χ'"
            using AaPa by blast
          let ?Fun_f = "λa. if A.ide a then (THE fa. ?P a fa) else B.null"
          interpret Fun_x: "functor" A B λa. A_B.Map x a
            using x A_B.ide_char by simp
          interpret Fun_x': "functor" A B λa. A_B.Map x' a
            using x' A_B.ide_char by simp
          text‹
            The arrows Fun_f a› are the components of a natural transformation.
            It is more work to verify the naturality than it seems like it ought to be.
›
          interpret φ: transformation_by_components A B
                         λa. A_B.Map x' a λa. A_B.Map x a ?Fun_f
          proof
            fix a
            assume a: "A.ide a"
            show "«?Fun_f a : A_B.Map x' a B A_B.Map x a»" using a AaPa by simp
            next
            fix a
            assume a: "A.arr a"
            text‹
\newcommand\xdom{\mathop{\rm dom}}
\newcommand\xcod{\mathop{\rm cod}}
$$\xymatrix{
  {x_{\xdom a}} \drtwocell\omit{\omit(A)} \ar[d]_{\chi_{\xdom a}} \ar[r]^{x_a} & {x_{\xcod a}}
     \ar[d]^{\chi_{\xcod a}} \\
  {D_{\xdom a}} \ar[r]^{D_a} & {D_{\xcod a}} \\
  {x'_{\xdom a}} \urtwocell\omit{\omit(B)} \ar@/^5em/[uu]^{f_{\xdom a}}_{\hspace{1em}(C)} \ar[u]^{\chi'_{\xdom a}}
     \ar[r]_{x'_a} & {x'_{\xcod a}} \ar[u]_{x'_{\xcod a}} \ar@/_5em/[uu]_{f_{\xcod a}}
}$$
›
            let ?x_dom_a = "A_B.Map x (A.dom a)"
            let ?x_cod_a = "A_B.Map x (A.cod a)"
            let ?x_a = "A_B.Map x a"
            have x_a: "«?x_a : ?x_dom_a B ?x_cod_a»"
              using a x A_B.ide_char by auto
            let ?x'_dom_a = "A_B.Map x' (A.dom a)"
            let ?x'_cod_a = "A_B.Map x' (A.cod a)"
            let ?x'_a = "A_B.Map x' a"
            have x'_a: "«?x'_a : ?x'_dom_a B ?x'_cod_a»"
              using a x' A_B.ide_char by auto
            let ?f_dom_a = "?Fun_f (A.dom a)"
            let ?f_cod_a = "?Fun_f (A.cod a)"
            have f_dom_a: "«?f_dom_a : ?x'_dom_a B ?x_dom_a»" using a AaPa by simp
            have f_cod_a: "«?f_cod_a : ?x'_cod_a B ?x_cod_a»" using a AaPa by simp
            interpret D_dom_a: diagram J B ‹at (A.dom a) D using a at_ide_is_diagram by simp
            interpret D_cod_a: diagram J B ‹at (A.cod a) D using a at_ide_is_diagram by simp
            interpret Da: natural_transformation J B ‹at (A.dom a) D ‹at (A.cod a) D ‹at a D
              using a functor_axioms functor_at_arr_is_transformation by simp
            interpret χ_dom_a: limit_cone J B ‹at (A.dom a) D ‹A_B.Map x (A.dom a)
                                              ‹at (A.dom a) χ
              using assms(2) a by auto
            interpret χ_cod_a: limit_cone J B ‹at (A.cod a) D ‹A_B.Map x (A.cod a)
                                              ‹at (A.cod a) χ
              using assms(2) a by auto
            interpret χ'_dom_a: cone J B ‹at (A.dom a) D ‹A_B.Map x' (A.dom a)
                                         ‹at (A.dom a) χ'
              using a cone_χ' cone_at_ide_is_cone by auto
            interpret χ'_cod_a: cone J B ‹at (A.cod a) D ‹A_B.Map x' (A.cod a)
                                         ‹at (A.cod a) χ'
              using a cone_χ' cone_at_ide_is_cone by auto
            text‹
              Now construct cones with apexes x_dom_a› and x'_dom_a›
              over @{term "at (A.cod a) D"} by forming the vertical composites of
              @{term "at (A.dom a) χ"} and @{term "at (A.cod a) χ'"} with the natural
              transformation @{term "at a D"}.
›
            interpret Daoχ_dom_a: vertical_composite J B
                                    χ_dom_a.A.map ‹at (A.dom a) D ‹at (A.cod a) D
                                    ‹at (A.dom a) χ ‹at a D ..
            interpret Daoχ_dom_a: cone J B ‹at (A.cod a) D ?x_dom_a Daoχ_dom_a.map
              using χ_dom_a.cone_axioms Da.natural_transformation_axioms vcomp_transformation_cone
              by metis
            interpret Daoχ'_dom_a: vertical_composite J B
                                     χ'_dom_a.A.map ‹at (A.dom a) D ‹at (A.cod a) D
                                     ‹at (A.dom a) χ' ‹at a D ..
            interpret Daoχ'_dom_a: cone J B ‹at (A.cod a) D ?x'_dom_a Daoχ'_dom_a.map
              using χ'_dom_a.cone_axioms Da.natural_transformation_axioms vcomp_transformation_cone
              by metis
            have Daoχ_dom_a: "D_cod_a.cone ?x_dom_a Daoχ_dom_a.map" ..
            have Daoχ'_dom_a: "D_cod_a.cone ?x'_dom_a Daoχ'_dom_a.map" ..
            text‹
              These cones are also obtained by transforming the cones @{term "at (A.cod a) χ"}
              and @{term "at (A.cod a) χ'"} by x_a› and x'_a›, respectively.
›
            have A: "Daoχ_dom_a.map = D_cod_a.cones_map ?x_a (at (A.cod a) χ)"
            proof
              fix j
              have "¬J.arr j  Daoχ_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) χ) j"
                using Daoχ_dom_a.is_extensional χ_cod_a.cone_axioms x_a by force
              moreover have
                   "J.arr j  Daoχ_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) χ) j"
              proof -
                assume j: "J.arr j"
                have "Daoχ_dom_a.map j = at a D j B at (A.dom a) χ (J.dom j)"
                  using j Daoχ_dom_a.map_simp_2 by simp
                also have "... = A_B.Map (D j) a B A_B.Map (χ (J.dom j)) (A.dom a)"
                  using a j at_simp by simp
                also have "... = A_B.Map (A_B.comp (D j) (χ (J.dom j))) a"
                  using a j A_B.Map_comp
                  by (metis (no_types, lifting) A.comp_arr_dom χ.is_natural_1
                      χ.preserves_reflects_arr)
                also have "... = A_B.Map (A_B.comp (χ (J.cod j)) (χ.A.map j)) a"
                  using a j χ.naturality by simp
                also have "... = A_B.Map (χ (J.cod j)) (A.cod a) B A_B.Map x a"
                  using a j x A_B.Map_comp
                  by (metis (no_types, lifting) A.comp_cod_arr χ.A.map_simp χ.is_natural_2
                            χ.preserves_reflects_arr)
                also have "... = at (A.cod a) χ (J.cod j) B A_B.Map x a"
                  using a j at_simp by simp
                also have "... = at (A.cod a) χ j B A_B.Map x a"
                  using a j χ_cod_a.is_natural_2 χ_cod_a.A.map_simp
                  by (metis J.arr_cod_iff_arr J.cod_cod)
                also have "... = D_cod_a.cones_map ?x_a (at (A.cod a) χ) j"
                  using a j x χ_cod_a.cone_axioms preserves_cod by simp
                finally show ?thesis by blast
              qed
              ultimately show "Daoχ_dom_a.map j = D_cod_a.cones_map ?x_a (at (A.cod a) χ) j"
                by blast
            qed
            have B: "Daoχ'_dom_a.map = D_cod_a.cones_map ?x'_a (at (A.cod a) χ')"
            proof
              fix j
              have "¬J.arr j 
                      Daoχ'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) χ') j"
                using Daoχ'_dom_a.is_extensional χ'_cod_a.cone_axioms x'_a by force
              moreover have
                  "J.arr j  Daoχ'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) χ') j"
              proof -
                assume j: "J.arr j"
                have "Daoχ'_dom_a.map j = at a D j B at (A.dom a) χ' (J.dom j)"
                  using j Daoχ'_dom_a.map_simp_2 by simp
                also have "... = A_B.Map (D j) a B A_B.Map (χ' (J.dom j)) (A.dom a)"
                  using a j at_simp by simp
                also have "... = A_B.Map (A_B.comp (D j) (χ' (J.dom j))) a"
                  using a j A_B.Map_comp
                  by (metis (no_types, lifting) A.comp_arr_dom χ'.is_natural_1
                      χ'.preserves_reflects_arr)
                also have "... = A_B.Map (A_B.comp (χ' (J.cod j)) (χ'.A.map j)) a"
                  using a j χ'.naturality by simp
                also have "... = A_B.Map (χ' (J.cod j)) (A.cod a) B A_B.Map x' a"
                  using a j x' A_B.Map_comp
                  by (metis (no_types, lifting) A.comp_cod_arr χ'.A.map_simp χ'.is_natural_2
                            χ'.preserves_reflects_arr)
                also have "... = at (A.cod a) χ' (J.cod j) B A_B.Map x' a"
                  using a j at_simp by simp
                also have "... = at (A.cod a) χ' j B A_B.Map x' a"
                  using a j χ'_cod_a.is_natural_2 χ'_cod_a.A.map_simp
                  by (metis J.arr_cod_iff_arr J.cod_cod)
                also have "... = D_cod_a.cones_map ?x'_a (at (A.cod a) χ') j"
                  using a j x' χ'_cod_a.cone_axioms preserves_cod by simp
                finally show ?thesis by blast
              qed
              ultimately show
                  "Daoχ'_dom_a.map j = D_cod_a.cones_map ?x'_a (at (A.cod a) χ') j"
                by blast
            qed
            text‹
              Next, we show that f_dom_a›, which is the unique arrow that transforms
              χ_dom_a› into χ'_dom_a›, is also the unique arrow that transforms
              Daoχ_dom_a› into Daoχ'_dom_a›.
›
            have C: "D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map = Daoχ'_dom_a.map"
            proof (intro NaturalTransformation.eqI)
              show "natural_transformation
                      J B χ'_dom_a.A.map (at (A.cod a) D) Daoχ'_dom_a.map" ..
              show "natural_transformation J B χ'_dom_a.A.map (at (A.cod a) D)
                      (D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map)"
              proof -
                interpret κ: cone J B ‹at (A.cod a) D ?x'_dom_a
                                  ‹D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map›
                proof -
                  have "b b' f.  f  B.hom b' b; D_cod_a.cone b Daoχ_dom_a.map 
                                      D_cod_a.cone b' (D_cod_a.cones_map f Daoχ_dom_a.map)"
                    using D_cod_a.cones_map_mapsto by blast
                  moreover have "D_cod_a.cone ?x_dom_a Daoχ_dom_a.map" ..
                  ultimately show "D_cod_a.cone ?x'_dom_a
                                     (D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map)"
                    using f_dom_a by simp
                qed
                show ?thesis ..
              qed
              show "j. J.ide j 
                          D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map j = Daoχ'_dom_a.map j"
              proof -
                fix j
                assume j: "J.ide j"
                have "D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map j =
                      Daoχ_dom_a.map j B ?f_dom_a"
                  using j f_dom_a Daoχ_dom_a.cone_axioms
                  by (elim B.in_homE, auto)
                also have "... = (at a D j B at (A.dom a) χ j) B ?f_dom_a"
                  using j Daoχ_dom_a.map_simp_ide by simp
                also have "... = at a D j B at (A.dom a) χ j B ?f_dom_a"
                  using B.comp_assoc by simp
                also have "... = at a D j B D_dom_a.cones_map ?f_dom_a (at (A.dom a) χ) j"
                  using j χ_dom_a.cone_axioms f_dom_a
                  by (elim B.in_homE, auto)
                also have "... = at a D j B at (A.dom a) χ' j"
                  using a AaPa A.ide_dom by presburger
                also have "... = Daoχ'_dom_a.map j"
                  using j Daoχ'_dom_a.map_simp_ide by simp
                finally show
                    "D_cod_a.cones_map ?f_dom_a Daoχ_dom_a.map j = Daoχ'_dom_a.map j"
                  by auto
              qed
            qed
            text‹
              Naturality amounts to showing that C f_cod_a x'_a = C x_a f_dom_a›.
              To do this, we show that both arrows transform @{term "at (A.cod a) χ"}
              into Daoχ'_cod_a›, thus they are equal by the universality of
              @{term "at (A.cod a) χ"}.
›
            have "∃!fa. «fa : ?x'_dom_a B ?x_cod_a» 
                        D_cod_a.cones_map fa (at (A.cod a) χ) = Daoχ'_dom_a.map"
              using Daoχ'_dom_a.cone_axioms a χ_cod_a.is_universal [of ?x'_dom_a Daoχ'_dom_a.map]
              by fast
            moreover have
                 "?f_cod_a B ?x'_a  B.hom ?x'_dom_a ?x_cod_a 
                  D_cod_a.cones_map (?f_cod_a B ?x'_a) (at (A.cod a) χ) = Daoχ'_dom_a.map"
            proof
              show "?f_cod_a B ?x'_a  B.hom ?x'_dom_a ?x_cod_a"
                using f_cod_a x'_a by blast
              show "D_cod_a.cones_map (?f_cod_a B ?x'_a) (at (A.cod a) χ) = Daoχ'_dom_a.map"
              proof -
                have "D_cod_a.cones_map (?f_cod_a B ?x'_a) (at (A.cod a) χ)
                         = restrict (D_cod_a.cones_map ?x'_a o D_cod_a.cones_map ?f_cod_a)
                                    (D_cod_a.cones (?x_cod_a))
                                    (at (A.cod a) χ)"
                  using x'_a D_cod_a.cones_map_comp [of ?f_cod_a ?x'_a] f_cod_a
                  by (elim B.in_homE, auto)
                also have "... = D_cod_a.cones_map ?x'_a
                                   (D_cod_a.cones_map ?f_cod_a (at (A.cod a) χ))"
                  using χ_cod_a.cone_axioms by simp
                also have "... = Daoχ'_dom_a.map"
                  using a B AaPa_map A.ide_cod by presburger
                finally show ?thesis by auto
              qed
            qed
            moreover have
                 "?x_a B ?f_dom_a  B.hom ?x'_dom_a ?x_cod_a 
                  D_cod_a.cones_map (?x_a B ?f_dom_a) (at (A.cod a) χ) = Daoχ'_dom_a.map"
            proof
              show "?x_a B ?f_dom_a  B.hom ?x'_dom_a ?x_cod_a"
                using f_dom_a x_a by blast
              show "D_cod_a.cones_map (?x_a B ?f_dom_a) (at (A.cod a) χ) = Daoχ'_dom_a.map"
              proof -
                have
                    "D_cod_a.cones (B.cod (A_B.Map x a)) = D_cod_a.cones (A_B.Map x (A.cod a))"
                  using a x by simp
                moreover have "B.seq ?x_a ?f_dom_a"
                  using f_dom_a x_a by (elim B.in_homE, auto)
                ultimately have
                     "D_cod_a.cones_map (?x_a B ?f_dom_a) (at (A.cod a) χ)
                         = restrict (D_cod_a.cones_map ?f_dom_a o D_cod_a.cones_map ?x_a)
                                    (D_cod_a.cones (?x_cod_a))
                                    (at (A.cod a) χ)"
                  using D_cod_a.cones_map_comp [of ?x_a ?f_dom_a] x_a by argo
                also have "... = D_cod_a.cones_map ?f_dom_a
                                   (D_cod_a.cones_map ?x_a (at (A.cod a) χ))"
                  using χ_cod_a.cone_axioms by simp
                also have "... = Daoχ'_dom_a.map"
                  using A C a AaPa by argo
                finally show ?thesis by blast
              qed
            qed
            ultimately show "?f_cod_a B ?x'_a = ?x_a B ?f_dom_a"
              using a χ_cod_a.is_universal by blast
          qed
          text‹
            The arrow from @{term x'} to @{term x} in [A, B]› determined by
            the natural transformation φ› transforms @{term χ} into @{term χ'}.
            Moreover, it is the unique such arrow, since the components of φ›
            are each determined by universality.
›
          let ?f = "A_B.MkArr (λa. A_B.Map x' a) (λa. A_B.Map x a) φ.map"
          have f_in_hom: "?f  A_B.hom x' x"
          proof -
            have arr_f: "A_B.arr ?f"
              using x' x A_B.arr_MkArr φ.natural_transformation_axioms by simp
            moreover have "A_B.MkIde (λa. A_B.Map x a) = x"
              using x A_B.ide_char A_B.MkArr_Map A_B.in_homE A_B.ide_in_hom by metis
            moreover have "A_B.MkIde (λa. A_B.Map x' a) = x'"
              using x' A_B.ide_char A_B.MkArr_Map A_B.in_homE A_B.ide_in_hom by metis
            ultimately show ?thesis
              using A_B.dom_char A_B.cod_char by auto
          qed
          have Fun_f: "a. A.ide a  A_B.Map ?f a = (THE fa. ?P a fa)"
            using f_in_hom φ.map_simp_ide by fastforce
          have cones_map_f: "cones_map ?f χ = χ'"
            using AaPa Fun_f at_ide_is_diagram assms(2) x x' cone_χ cone_χ' f_in_hom Fun_f
                  cones_map_pointwise
            by presburger
          show "«?f : x' [A,B] x»  cones_map ?f χ = χ'" using f_in_hom cones_map_f by auto
          show "f'. «f' : x' [A,B] x»  cones_map f' χ = χ'  f' = ?f"
          proof -
            fix f'
            assume f': "«f' : x' [A,B] x»  cones_map f' χ = χ'"
            have 0: "a. A.ide a 
                           diagram.cones_map J B (at a D) (A_B.Map f' a) (at a χ) = at a χ'"
              using f' cone_χ cone_χ' cones_map_pointwise by blast
            have "f' = A_B.MkArr (A_B.Dom f') (A_B.Cod f') (A_B.Map f')"
              using f' A_B.MkArr_Map by auto
            also have "... = ?f"
            proof (intro A_B.MkArr_eqI)
              show "A_B.arr (A_B.MkArr (A_B.Dom f') (A_B.Cod f') (A_B.Map f'))"
                using f' calculation by blast
              show 1: "A_B.Dom f' = A_B.Map x'" using f' A_B.Map_dom by auto
              show 2: "A_B.Cod f' = A_B.Map x" using f' A_B.Map_cod by auto
              show "A_B.Map f' = φ.map"
              proof (intro NaturalTransformation.eqI)
                show "natural_transformation A B (A_B.Map x') (A_B.Map x) φ.map" ..
                show "natural_transformation A B (A_B.Map x') (A_B.Map x) (A_B.Map f')"
                  using f' 1 2 A_B.arr_char [of f'] by auto
                show "a. A.ide a  A_B.Map f' a = φ.map a"
                proof -
                  fix a
                  assume a: "A.ide a"
                  interpret Da: diagram J B ‹at a D using a at_ide_is_diagram by auto
                  interpret Fun_f': natural_transformation A B ‹A_B.Dom f' ‹A_B.Cod f'
                                                           ‹A_B.Map f'
                    using f' A_B.arr_char by fast
                  have "A_B.Map f' a  B.hom (A_B.Map x' a) (A_B.Map x a)"
                    using a f' Fun_f'.preserves_hom A.ide_in_hom by auto
                  hence "?P a (A_B.Map f' a)" using a 0 [of a] by simp
                  moreover have "?P a (φ.map a)"
                    using a φ.map_simp_ide Fun_f AaPa by presburger
                  ultimately show "A_B.Map f' a = φ.map a" using a EU by blast
                qed
              qed
            qed
            finally show "f' = ?f" by auto
          qed
        qed
      qed
    qed

  end

  context functor_category
  begin

    text‹
      A functor category [A, B]› has limits of shape @{term[source=true] J}
      whenever @{term B} has limits of shape @{term[source=true] J}.
›

    lemma has_limits_of_shape_if_target_does:
    assumes "category (J :: 'j comp)"
    and "B.has_limits_of_shape J"
    shows "has_limits_of_shape J"
    proof (unfold has_limits_of_shape_def)
      have "D. diagram J comp D  (x χ. limit_cone J comp D x χ)"
      proof -
        fix D
        assume D: "diagram J comp D"
        interpret J: category J using assms(1) by auto
        interpret JxA: product_category J A ..
        interpret D: diagram J comp D using D by auto
        interpret D: diagram_in_functor_category A B J D ..
        interpret Curry: currying J A B ..
        text‹
          Given diagram @{term D} in [A, B]›, choose for each object a›
          of A› a limit cone (la, χa)› for at a D› in B›.
›
        let ?l = "λa. diagram.some_limit J B (D.at a D)"
        let  = "λa. diagram.some_limit_cone J B (D.at a D)"
        have: "a. A.ide a  diagram.limit_cone J B (D.at a D) (?l a) ( a)"
        proof -
          fix a
          assume a: "A.ide a"
          interpret Da: diagram J B ‹D.at a D
            using a D.at_ide_is_diagram by blast
          show "limit_cone J B (D.at a D) (?l a) ( a)"
            using assms(2) B.has_limits_of_shape_def Da.diagram_axioms
                  Da.limit_cone_some_limit_cone
            by auto
        qed
        text‹
          The choice of limit cones induces a limit functor from A› to B›.
›
        interpret uncurry_D: diagram JxA.comp B "Curry.uncurry D"
        proof -
          interpret "functor" JxA.comp B ‹Curry.uncurry D
            using D.functor_axioms Curry.uncurry_preserves_functors by simp
          interpret binary_functor J A B ‹Curry.uncurry D ..
          show "diagram JxA.comp B (Curry.uncurry D)" ..
        qed
        interpret uncurry_D: parametrized_diagram J A B ‹Curry.uncurry D ..
        let ?L = "uncurry_D.L ?l "
        let ?P = "uncurry_D.P ?l "
        interpret L: "functor" A B ?L
          using lχ uncurry_D.chosen_limits_induce_functor [of ?l ] by simp
        have L_ide: "a. A.ide a  ?L a = ?l a"
          using uncurry_D.L_ide [of ?l ]by blast
        have L_arr: "a. A.arr a  (∃!f. ?P a f)  ?P a (?L a)"
          using uncurry_D.L_arr [of ?l ]by blast
        text‹
          The functor L› extends to a functor L'› from JxA›
          to B› that is constant on J›.
›
        let ?L' = "λja. if JxA.arr ja then ?L (snd ja) else B.null"
        let ?P' = "λja. ?P (snd ja)"
        interpret L': "functor" JxA.comp B ?L'
          apply unfold_locales
          using L.preserves_arr L.preserves_dom L.preserves_cod
              apply auto[4]
          using L.preserves_comp JxA.comp_char by (elim JxA.seqE, auto)
        have "ja. JxA.arr ja  (∃!f. ?P' ja f)  ?P' ja (?L' ja)"
        proof -
          fix ja
          assume ja: "JxA.arr ja"
          have "A.arr (snd ja)" using ja by blast
          thus "(∃!f. ?P' ja f)  ?P' ja (?L' ja)"
            using ja L_arr by presburger
        qed
        hence L'_arr: "ja. JxA.arr ja  ?P' ja (?L' ja)" by blast
        have L'_ide: "ja.  J.arr (fst ja); A.ide (snd ja)   ?L' ja = ?l (snd ja)"
          using L_ide lχ by force
        have L'_arr_map:
             "ja. JxA.arr ja  uncurry_D.P ?l  (snd ja) (uncurry_D.L ?l  (snd ja))"
           using L'_arr by presburger
        text‹
          The map that takes an object (j, a)› of JxA› to the component
          χ a j› of the limit cone χ a› is a natural transformation
          from L› to uncurry D›.
›
        let ?χ' = "λja.  (snd ja) (fst ja)"
        interpret χ': transformation_by_components JxA.comp B ?L' ‹Curry.uncurry D ?χ'
        proof
          fix ja
          assume ja: "JxA.ide ja"
          let ?j = "fst ja"
          let ?a = "snd ja"
          interpret χa: limit_cone J B ‹D.at ?a D ?l ?a  ?a
            using ja lχ by blast
          show "«?χ' ja : ?L' ja B Curry.uncurry D ja»"
            using ja L'_ide [of ja] by force
          next
          fix ja
          assume ja: "JxA.arr ja"
          let ?j = "fst ja"
          let ?a = "snd ja"
          have j: "J.arr ?j" using ja by simp
          have a: "A.arr ?a" using ja by simp
          interpret D_dom_a: diagram J B ‹D.at (A.dom ?a) D
            using a D.at_ide_is_diagram by auto
          interpret D_cod_a: diagram J B ‹D.at (A.cod ?a) D
            using a D.at_ide_is_diagram by auto
          interpret Da: natural_transformation J B
                          ‹D.at (A.dom ?a) D ‹D.at (A.cod ?a) D ‹D.at ?a D
            using a D.functor_axioms D.functor_at_arr_is_transformation by simp
          interpret χ_dom_a: limit_cone J B ‹D.at (A.dom ?a) D ?l (A.dom ?a)
                                (A.dom ?a)
            using a lχ by simp
          interpret χ_cod_a: limit_cone J B ‹D.at (A.cod ?a) D ?l (A.cod ?a)
                                (A.cod ?a)
            using a lχ by simp
          interpret Daoχ_dom_a: vertical_composite J B
                                  χ_dom_a.A.map ‹D.at (A.dom ?a) D ‹D.at (A.cod ?a) D
                                   (A.dom ?a) ‹D.at ?a D
            ..
          interpret Daoχ_dom_a: cone J B ‹D.at (A.cod ?a) D ?l (A.dom ?a) Daoχ_dom_a.map ..
          show "?χ' (JxA.cod ja) B ?L' ja = B (Curry.uncurry D ja) (?χ' (JxA.dom ja))"
          proof -
            have "?χ' (JxA.cod ja) B ?L' ja =  (A.cod ?a) (J.cod ?j) B ?L' ja"
              using ja by fastforce
            also have "... = D_cod_a.cones_map (?L' ja) ( (A.cod ?a)) (J.cod ?j)"
              using ja L'_arr_map [of ja] χ_cod_a.cone_axioms by auto
            also have "... = Daoχ_dom_a.map (J.cod ?j)"
              using ja χ_cod_a.induced_arrowI Daoχ_dom_a.cone_axioms L'_arr by presburger
            also have "... = D.at ?a D (J.cod ?j) B D_dom_a.some_limit_cone (J.cod ?j)"
              using ja Daoχ_dom_a.map_simp_ide by fastforce
            also have "... = D.at ?a D (J.cod ?j) B D.at (A.dom ?a) D ?j B ?χ' (JxA.dom ja)"
              using ja χ_dom_a.naturality χ_dom_a.ide_apex apply simp
              by (metis B.comp_arr_ide χ_dom_a.preserves_reflects_arr)
            also have "... = (D.at ?a D (J.cod ?j) B D.at (A.dom ?a) D ?j) B ?χ' (JxA.dom ja)"
              using j ja B.comp_assoc by presburger
            also have "... = B (D.at ?a D ?j) (?χ' (JxA.dom ja))"
              using a j ja Map_comp A.comp_arr_dom D.is_natural_2 by simp
           also have "... = Curry.uncurry D ja B ?χ' (JxA.dom ja)"
             using Curry.uncurry_def by simp
           finally show ?thesis by auto
         qed
       qed
       text‹
         Since χ'› is constant on J›, curry χ'› is a cone over D›.
›
       interpret constL: constant_functor J comp ‹MkIde ?L
         using L.natural_transformation_axioms MkArr_in_hom ide_in_hom L.functor_axioms
         by unfold_locales blast
       (* TODO: This seems a little too involved. *)
       have curry_L': "constL.map = Curry.curry ?L' ?L' ?L'"
       proof
         fix j
         have "¬J.arr j  constL.map j = Curry.curry ?L' ?L' ?L' j"
           using Curry.curry_def constL.is_extensional by simp
         moreover have "J.arr j  constL.map j = Curry.curry ?L' ?L' ?L' j"
           using Curry.curry_def constL.value_is_ide in_homE ide_in_hom by auto
         ultimately show "constL.map j = Curry.curry ?L' ?L' ?L' j" by blast
       qed
       hence uncurry_constL: "Curry.uncurry constL.map = ?L'"
         using L'.natural_transformation_axioms Curry.uncurry_curry by simp
       interpret curry_χ': natural_transformation J comp constL.map D
                             ‹Curry.curry ?L' (Curry.uncurry D) χ'.map›
       proof -
         have "Curry.curry (Curry.uncurry D) (Curry.uncurry D) (Curry.uncurry D) = D"
           using Curry.curry_uncurry D.functor_axioms D.natural_transformation_axioms
           by blast
         thus "natural_transformation J comp constL.map D
                 (Curry.curry ?L' (Curry.uncurry D) χ'.map)"
           using Curry.curry_preserves_transformations curry_L' χ'.natural_transformation_axioms
           by force
       qed
       interpret curry_χ': cone J comp D ‹MkIde ?L ‹Curry.curry ?L' (Curry.uncurry D) χ'.map›
         ..
       text‹
         The value of curry_χ'› at each object a› of A› is the
         limit cone χ a›, hence curry_χ'› is a limit cone.
›
       have 1: "a. A.ide a  D.at a (Curry.curry ?L' (Curry.uncurry D) χ'.map) =  a"
       proof -
         fix a
         assume a: "A.ide a"
         have "D.at a (Curry.curry ?L' (Curry.uncurry D) χ'.map) =
                 (λj. Curry.uncurry (Curry.curry ?L' (Curry.uncurry D) χ'.map) (j, a))"
           using a by simp
         moreover have "... = (λj. χ'.map (j, a))"
           using a Curry.uncurry_curry χ'.natural_transformation_axioms by simp
         moreover have "... =  a"
         proof (intro NaturalTransformation.eqI)
           interpret χa: limit_cone J B ‹D.at a D ?l a  a using a lχ by simp
           interpret χ': binary_functor_transformation J A B ?L' ‹Curry.uncurry D χ'.map ..
           show "natural_transformation J B χa.A.map (D.at a D) ( a)" ..
           show "natural_transformation J B χa.A.map (D.at a D) (λj. χ'.map (j, a))"
           proof -
             have "χa.A.map = (λj. ?L' (j, a))"
               using a χa.A.map_def L'_ide by auto
             thus ?thesis
               using a χ'.fixing_ide_gives_natural_transformation_2 by simp
           qed
           fix j
           assume j: "J.ide j"
           show "χ'.map (j, a) =  a j"
             using a j χ'.map_simp_ide by simp
         qed
         ultimately show "D.at a (Curry.curry ?L' (Curry.uncurry D) χ'.map) =  a" by simp
       qed
       hence 2: "a. A.ide a  diagram.limit_cone J B (D.at a D) (?l a)
                                (D.at a (Curry.curry ?L' (Curry.uncurry D) χ'.map))"
         usingby simp
       hence "limit_cone J comp D (MkIde ?L) (Curry.curry ?L' (Curry.uncurry D) χ'.map)"
         using 1 2 L.functor_axioms L_ide curry_χ'.cone_axioms curry_L'
               D.cone_is_limit_if_pointwise_limit
         by simp
       thus "x χ. limit_cone J comp D x χ" by blast
     qed
     thus "D. diagram J comp D  (x χ. limit_cone J comp D x χ)" by blast
    qed

    lemma has_limits_if_target_does:
    assumes "B.has_limits (undefined :: 'j)"
    shows "has_limits (undefined :: 'j)"
      using assms B.has_limits_def has_limits_def has_limits_of_shape_if_target_does by fast

  end

  section "The Yoneda Functor Preserves Limits"

  text‹
    In this section, we show that the Yoneda functor from C› to [Cop, S]›
    preserves limits.
›

  context yoneda_functor
  begin

    lemma preserves_limits:
    fixes J :: "'j comp"
    assumes "diagram J C D" and "diagram.has_as_limit J C D a"
    shows "diagram.has_as_limit J Cop_S.comp (map o D) (map a)"
    proof -
      text‹
        The basic idea of the proof is as follows:
        If χ› is a limit cone in C›, then for every object a'›
        of Cop› the evaluation of Y o χ› at a'› is a limit cone
        in S›.  By the results on limits in functor categories,
        this implies that Y o χ› is a limit cone in [Cop, S]›.
›
      interpret J: category J using assms(1) diagram_def by auto
      interpret D: diagram J C D using assms(1) by auto
      from assms(2) obtain χ where χ: "D.limit_cone a χ" by blast
      interpret χ: limit_cone J C D a χ using χ by auto
      have a: "C.ide a" using χ.ide_apex by auto
      interpret YoD: diagram J Cop_S.comp ‹map o D
        using D.diagram_axioms functor_axioms preserves_diagrams [of J D] by simp
      interpret YoD: diagram_in_functor_category Cop.comp S J ‹map o D ..
      interpret Yoχ: cone J Cop_S.comp ‹map o D ‹map a ‹map o χ
        using χ.cone_axioms preserves_cones by blast
      have "a'. C.ide a' 
                   limit_cone J S (YoD.at a' (map o D))
                                  (Cop_S.Map (map a) a') (YoD.at a' (map o χ))"
      proof -
        fix a'
        assume a': "C.ide a'"
        interpret A': constant_functor J C a'
          using a' by (unfold_locales, auto)
        interpret YoD_a': diagram J S ‹YoD.at a' (map o D)
          using a' YoD.at_ide_is_diagram by simp
        interpret Yoχ_a': cone J S ‹YoD.at a' (map o D)
                                   ‹Cop_S.Map (map a) a' ‹YoD.at a' (map o χ)
          using a' YoD.cone_at_ide_is_cone Yoχ.cone_axioms by fastforce
        have eval_at_ide: "j. J.ide j  YoD.at a' (map  D) j = Hom.map (a', D j)"
        proof -
          fix j
          assume j: "J.ide j"
          have "YoD.at a' (map  D) j = Cop_S.Map (map (D j)) a'"
            using a' j YoD.at_simp YoD.preserves_arr [of j] by auto
          also have "... = Y (D j) a'" using Y_def by simp
          also have "... = Hom.map (a', D j)" using a' j D.preserves_arr by simp
          finally show "YoD.at a' (map  D) j = Hom.map (a', D j)" by auto
        qed
        have eval_at_arr: "j. J.arr j  YoD.at a' (map  χ) j = Hom.map (a', χ j)"
        proof -
          fix j
          assume j: "J.arr j"
          have "YoD.at a' (map  χ) j = Cop_S.Map ((map o χ) j) a'"
            using a' j YoD.at_simp [of a' j "map o χ"] preserves_arr by fastforce
          also have "... = Y (χ j) a'" using Y_def by simp
            also have "... = Hom.map (a', χ j)" using a' j by simp
          finally show "YoD.at a' (map  χ) j = Hom.map (a', χ j)" by auto
        qed
        have Fun_map_a_a': "Cop_S.Map (map a) a' = Hom.map (a', a)"
          using a a' map_simp preserves_arr [of a] by simp
        show "limit_cone J S (YoD.at a' (map o D))
                             (Cop_S.Map (map a) a') (YoD.at a' (map o χ))"
        proof
          fix x σ
          assume σ: "YoD_a'.cone x σ"
          interpret σ: cone J S ‹YoD.at a' (map o D) x σ using σ by auto
          have x: "S.ide x" using σ.ide_apex by simp
          text‹
            For each object j› of J›, the component σ j›
            is an arrow in S.hom x (Hom.map (a', D j))›.
            Each element e ∈ S.set x› therefore determines an arrow
            ψ (a', D j) (S.Fun (σ j) e) ∈ C.hom a' (D j)›.
            These arrows are the components of a cone κ e› over @{term D}
            with apex @{term a'}.
›
          have σj: "j. J.ide j  «σ j : x S Hom.map (a', D j)»"
            using eval_at_ide σ.preserves_hom J.ide_in_hom by force
          have κ: "e. e  S.set x 
                        transformation_by_components
                          J C A'.map D (λj. ψ (a', D j) (S.Fun (σ j) e))"
          proof -
            fix e
            assume e: "e  S.set x"
            show "transformation_by_components J C A'.map D (λj. ψ (a', D j) (S.Fun (σ j) e))"
            proof
              fix j
              assume j: "J.ide j"
              show "«ψ (a', D j) (S.Fun (σ j) e) : A'.map j  D j»"
                using e j S.Fun_mapsto [of "σ j"] A'.preserves_ide Hom.set_map eval_at_ide
                      Hom.ψ_mapsto [of "A'.map j" "D j"]
                by force
              next
              fix j
              assume j: "J.arr j"
              show (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e)  A'.map j =
                    D j  ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)"
              proof -
                have (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e)  A'.map j =
                      ψ (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e)  a'"
                  using A'.map_simp j by simp
                also have "... = ψ (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e)"
                proof -
                  have (a', D (J.cod j)) (S.Fun (σ (J.cod j)) e)  C.hom a' (D (J.cod j))"
                    using a' e j Hom.ψ_mapsto [of "A'.map j" "D (J.cod j)"] A'.map_simp
                          S.Fun_mapsto [of "σ (J.cod j)"] Hom.set_map eval_at_ide
                    by auto
                  thus ?thesis
                    using C.comp_arr_dom by fastforce
                qed
                also have "... = ψ (a', D (J.cod j)) (S.Fun (Y (D j) a') (S.Fun (σ (J.dom j)) e))"
                proof -
                  have "S.Fun (Y (D j) a') (S.Fun (σ (J.dom j)) e) =
                        (S.Fun (Y (D j) a') o S.Fun (σ (J.dom j))) e"
                    by simp
                  also have "... = S.Fun (Y (D j) a' S σ (J.dom j)) e"
                    using a' e j Y_arr_ide(1) S.in_homE σj eval_at_ide S.Fun_comp by force
                  also have "... = S.Fun (σ (J.cod j)) e"
                    using a' j x σ.is_natural_2 σ.A.map_simp S.comp_arr_dom J.arr_cod_iff_arr
                          J.cod_cod YoD.preserves_arr σ.is_natural_1 YoD.at_simp
                    by auto
                  finally have
                      "S.Fun (Y (D j) a') (S.Fun (σ (J.dom j)) e) = S.Fun (σ (J.cod j)) e"
                    by auto
                  thus ?thesis by simp
                qed
                also have "... = D j  ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)"
                proof -
                  have "S.Fun (Y (D j) a') (S.Fun (σ (J.dom j)) e) =
                         φ (a', D (J.cod j)) (D j  ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e))"
                  proof -
                    have "S.Fun (σ (J.dom j)) e  Hom.set (a', D (J.dom j))"
                      using a' e j σj S.Fun_mapsto [of "σ (J.dom j)"] Hom.set_map
                            YoD.at_simp eval_at_ide
                      by auto
                    moreover have "C.arr (ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)) 
                                   C.dom (ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)) = a'"
                      using a' e j σj S.Fun_mapsto [of "σ (J.dom j)"] Hom.set_map eval_at_ide
                            Hom.ψ_mapsto [of a' "D (J.dom j)"]
                      by auto
                    ultimately show ?thesis
                      using a' e j Hom.Fun_map C.comp_arr_dom by force
                  qed
                  moreover have "D j  ψ (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)
                                    C.hom a' (D (J.cod j))"
                  proof -
                    have (a', D (J.dom j)) (S.Fun (σ (J.dom j)) e)  C.hom a' (D (J.dom j))"
                      using a' e j Hom.ψ_mapsto [of a' "D (J.dom j)"] eval_at_ide
                            S.Fun_mapsto [of "σ (J.dom j)"] Hom.set_map
                      by auto
                    thus ?thesis using j D.preserves_hom by blast
                  qed
                  ultimately show ?thesis using a' j Hom.ψ_φ by simp
                qed
                finally show ?thesis by auto
              qed
            qed
          qed
          let  = "λe. transformation_by_components.map J C A'.map
                          (λj. ψ (a', D j) (S.Fun (σ j) e))"
          have cone_κe: "e. e  S.set x  D.cone a' ( e)"
          proof -
            fix e
            assume e: "e  S.set x"
            interpret κe: transformation_by_components J C A'.map D
                            λj. ψ (a', D j) (S.Fun (σ j) e)
              using e κ by blast
            show "D.cone a' ( e)" ..
          qed
          text‹
            Since κ e› is a cone for each element e› of S.set x›,
            by the universal property of the limit cone χ› there is a unique arrow
            fe ∈ C.hom a' a› that transforms χ› to κ e›.
›
          have ex_fe: "e. e  S.set x  ∃!fe. «fe : a'  a»  D.cones_map fe χ =  e"
            using cone_κe χ.is_universal by simp
          text‹
            The map taking e ∈ S.set x› to fe ∈ C.hom a' a›
            determines an arrow f ∈ S.hom x (Hom (a', a))› that
            transforms the cone obtained by evaluating Y o χ› at a'›
            to the cone σ›.
›
          let ?f = "S.mkArr (S.set x) (Hom.set (a', a))
                            (λe. φ (a', a) (χ.induced_arrow a' ( e)))"
          have 0: "(λe. φ (a', a) (χ.induced_arrow a' ( e)))  S.set x  Hom.set (a', a)"
          proof
            fix e
            assume e: "e  S.set x"
            interpret κe: cone J C D a'  e using e cone_κe by simp
            have "χ.induced_arrow a' ( e)  C.hom a' a"
              using a a' e ex_fe χ.induced_arrowI κe.cone_axioms by simp
            thus "φ (a', a) (χ.induced_arrow a' ( e))  Hom.set (a', a)"
              using a a' Hom.φ_mapsto by auto
          qed
          have f: "«?f : x S Hom.map (a', a)»"
          proof -
            have "(λe. φ (a', a) (χ.induced_arrow a' ( e)))  S.set x  Hom.set (a', a)"
            proof
              fix e
              assume e: "e  S.set x"
              interpret κe: cone J C D a'  e using e cone_κe by simp
              have "χ.induced_arrow a' ( e)  C.hom a' a"
                using a a' e ex_fe χ.induced_arrowI κe.cone_axioms by simp
              thus "φ (a', a) (χ.induced_arrow a' ( e))  Hom.set (a', a)"
                using a a' Hom.φ_mapsto by auto
            qed
            thus ?thesis
              using a a' x σ.ide_apex S.mkArr_in_hom [of "S.set x" "Hom.set (a', a)"]
                    Hom.set_subset_Univ S.mkIde_set
              by simp
          qed
          have "YoD_a'.cones_map ?f (YoD.at a' (map o χ)) = σ"
          proof (intro NaturalTransformation.eqI)
            show "natural_transformation J S σ.A.map (YoD.at a' (map o D)) σ"
              using σ.natural_transformation_axioms by auto
            have 1: "S.cod ?f = Cop_S.Map (map a) a'"
              using f Fun_map_a_a' by force
            interpret YoD_a'of: cone J S ‹YoD.at a' (map o D) x
                                     ‹YoD_a'.cones_map ?f (YoD.at a' (map o χ))
            proof -
              have "YoD_a'.cone (S.cod ?f) (YoD.at a' (map o χ))"
                using a a' f Yoχ_a'.cone_axioms preserves_arr [of a] by auto
              hence "YoD_a'.cone (S.dom ?f) (YoD_a'.cones_map ?f (YoD.at a' (map o χ)))"
                using f YoD_a'.cones_map_mapsto S.arrI by blast
              thus "cone J S (YoD.at a' (map o D)) x
                                        (YoD_a'.cones_map ?f (YoD.at a' (map o χ)))"
                using f by auto
            qed
            show "natural_transformation J S σ.A.map (YoD.at a' (map o D))
                                         (YoD_a'.cones_map ?f (YoD.at a' (map o χ)))" ..
            fix j
            assume j: "J.ide j"
            have "YoD_a'.cones_map ?f (YoD.at a' (map o χ)) j = YoD.at a' (map o χ) j S ?f"
              using f j Fun_map_a_a' Yoχ_a'.cone_axioms by fastforce
            also have "... = σ j"
            proof (intro S.arr_eqI)
              show "S.par (YoD.at a' (map o χ) j S ?f) (σ j)"
                using 1 f j x YoD_a'.preserves_hom by fastforce
              show "S.Fun (YoD.at a' (map o χ) j S ?f) = S.Fun (σ j)"
              proof
                fix e
                have "e  S.set x  S.Fun (YoD.at a' (map o χ) j S ?f) e = S.Fun (σ j) e"
                  using 1 f j x S.Fun_mapsto [of "σ j"] σ.A.map_simp
                        extensional_arb [of "S.Fun (σ j)"]
                  by auto
                moreover have "e  S.set x 
                                  S.Fun (YoD.at a' (map o χ) j S ?f) e = S.Fun (σ j) e"
                proof -
                  assume e: "e  S.set x"
                  interpret κe: transformation_by_components J C A'.map D
                                  λj. ψ (a', D j) (S.Fun (σ j) e)
                    using e κ by blast
                  interpret κe: cone J C D a'  e using e cone_κe by simp
                  have induced_arrow: "χ.induced_arrow a' ( e)  C.hom a' a"
                    using a a' e ex_fe χ.induced_arrowI κe.cone_axioms by simp
                  have "S.Fun (YoD.at a' (map o χ) j S ?f) e =
                          restrict (S.Fun (YoD.at a' (map o χ) j) o S.Fun ?f) (S.set x) e"
                    using 1 e f j S.Fun_comp YoD_a'.preserves_hom by force
                  also have "... = (φ (a', D j) o C (χ j) o ψ (a', a)) (S.Fun ?f e)"
                    using j a' f e Hom.map_simp_2 S.Fun_mkArr Hom.preserves_arr [of "(a', χ j)"]
                          eval_at_arr S.arr_mkArr
                    by (elim S.in_homE, auto)
                  also have "... = (φ (a', D j) o C (χ j) o ψ (a', a))
                                     (φ (a', a) (χ.induced_arrow a' ( e)))"
                    using e f S.Fun_mkArr by fastforce
                  also have "... = φ (a', D j) (D.cones_map (χ.induced_arrow a' ( e)) χ j)"
                      using a a' e j 0 Hom.ψ_φ induced_arrow χ.cone_axioms by auto
                  also have "... = φ (a', D j) ( e j)"
                    using χ.induced_arrowI κe.cone_axioms by fastforce
                  also have "... = φ (a', D j) (ψ (a', D j) (S.Fun (σ j) e))"
                    using j κe.map_def [of j] by simp
                  also have "... = S.Fun (σ j) e"
                  proof -
                    have "S.Fun (σ j) e  Hom.set (a', D j)"
                      using a' e j S.Fun_mapsto [of "σ j"] eval_at_ide Hom.set_map by auto
                    thus ?thesis
                      using a' j Hom.φ_ψ C.ide_in_hom J.ide_in_hom by blast
                  qed
                  finally show "S.Fun (YoD.at a' (map o χ) j S ?f) e = S.Fun (σ j) e"
                    by auto
                qed
                ultimately show "S.Fun (YoD.at a' (map o χ) j S ?f) e = S.Fun (σ j) e"
                  by auto
              qed
            qed
            finally show "YoD_a'.cones_map ?f (YoD.at a' (map o χ)) j = σ j" by auto
          qed
          hence ff: "?f  S.hom x (Hom.map (a', a)) 
                     YoD_a'.cones_map ?f (YoD.at a' (map o χ)) = σ"
            using f by auto
          text‹
            Any other arrow f' ∈ S.hom x (Hom.map (a', a))› that
            transforms the cone obtained by evaluating Y o χ› at @{term a'}
            to the cone @{term σ}, must equal f›, showing that f›
            is unique.
›
          moreover have "f'. «f' : x S Hom.map (a', a)» 
                              YoD_a'.cones_map f' (YoD.at a' (map o χ)) = σ
                                 f' = ?f"
          proof -
            fix f'
            assume f': "«f' : x S Hom.map (a', a)» 
                        YoD_a'.cones_map f' (YoD.at a' (map o χ)) = σ"
            show "f' = ?f"
            proof (intro S.arr_eqI)
              show par: "S.par f' ?f" using f f' by (elim S.in_homE, auto)
              show "S.Fun f' = S.Fun ?f"
              proof
                fix e
                have "e  S.set x  S.Fun f' e = S.Fun ?f e"
                  using f f' x S.Fun_mapsto extensional_arb S.Fun_in_terms_of_comp
                  by fastforce
                moreover have "e  S.set x  S.Fun f' e = S.Fun ?f e"
                proof -
                  assume e: "e  S.set x"
                  have fe: "S.Fun ?f e  Hom.set (a', a)"
                    using e f S.arr_mkArr par by auto
                  have f'e: "S.Fun f' e  Hom.set (a', a)"
                    using a a' e f' S.Fun_mapsto Hom.set_map by fastforce
                  have 1: "«ψ (a', a) (S.Fun f' e) : a'  a»"
                    using a a' e f' f'e S.Fun_mapsto Hom.ψ_mapsto Hom.set_map by blast
                  have 2: "«ψ (a', a) (S.Fun ?f e) : a'  a»"
                    using a a' e f' fe S.Fun_mapsto Hom.ψ_mapsto Hom.set_map by blast
                  interpret χofe: cone J C D a' ‹D.cones_map (ψ (a', a) (S.Fun ?f e)) χ
                  proof -
                    have "D.cones_map (ψ (a', a) (S.Fun ?f e))  D.cones a  D.cones a'"
                      using 2 D.cones_map_mapsto [of (a', a) (S.Fun ?f e)"]
                      by (elim C.in_homE, auto)
                    thus "cone J C D a' (D.cones_map (ψ (a', a) (S.Fun ?f e)) χ)"
                      using χ.cone_axioms by blast
                  qed
                  have A: "h j. h  C.hom a' a  J.arr j 
                                   S.Fun (YoD.at a' (map o χ) j) (φ (a', a) h)
                                     = φ (a', D (J.cod j)) (χ j  h)"
                  proof -
                    fix h j
                    assume j: "J.arr j"
                    assume h: "h  C.hom a' a"
                    have "S.Fun (YoD.at a' (map o χ) j) (φ (a', a) h)
                              = (φ (a', D (J.cod j))  C (χ j)  ψ (a', a)) (φ (a', a) h)"
                    proof -
                      have "S.Fun (YoD.at a' (map o χ) j)
                              = restrict (φ (a', D (J.cod j))  C (χ j)  ψ (a', a))
                                         (Hom.set (a', a))"
                      proof -
                        have "S.Fun (YoD.at a' (map o χ) j) = S.Fun (Y (χ j) a')"
                          using a' j YoD.at_simp Y_def Yoχ.preserves_reflects_arr [of j]
                          by simp
                        also have "... = restrict (φ (a', D (J.cod j))  C (χ j)  ψ (a', a))
                                                  (Hom.set (a', a))"
                          using a' j χ.preserves_hom [of j "J.dom j" "J.cod j"]
                                Y_arr_ide [of a' "χ j" a "D (J.cod j)"] χ.A.map_simp S.Fun_mkArr
                          by fastforce
                        finally show ?thesis by blast
                      qed
                      thus ?thesis
                        using a a' h Hom.φ_mapsto by auto
                    qed
                    also have "... = φ (a', D (J.cod j)) (χ j  h)"
                      using a a' h Hom.ψ_φ by simp
                    finally show "S.Fun (YoD.at a' (map o χ) j) (φ (a', a) h)
                                    = φ (a', D (J.cod j)) (χ j  h)"
                      by auto
                  qed
                  have "D.cones_map (ψ (a', a) (S.Fun f' e)) χ =
                        D.cones_map (ψ (a', a) (S.Fun ?f e)) χ"
                  proof
                    fix j
                    have "¬J.arr j  D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
                                       D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
                      using 1 2 χ.cone_axioms by (elim C.in_homE, auto)
                    moreover have "J.arr j  D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
                                               D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
                    proof -
                      assume j: "J.arr j"
                      have "D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
                              χ j  ψ (a', a) (S.Fun f' e)"
                        using j 1 χ.cone_axioms by auto
                      also have "... = ψ (a', D (J.cod j)) (S.Fun (σ j) e)"
                      proof -
                        have (a', D (J.cod j)) (S.Fun (YoD.at a' (map o χ) j) (S.Fun f' e)) =
                                ψ (a', D (J.cod j))
                                  (φ (a', D (J.cod j)) (χ j  ψ (a', a) (S.Fun f' e)))"
                          using j a a' f'e A Hom.φ_ψ Hom.ψ_mapsto by force
                        moreover have "χ j  ψ (a', a) (S.Fun f' e)  C.hom a' (D (J.cod j))"
                          using a a' j f'e Hom.ψ_mapsto χ.preserves_hom [of j "J.dom j" "J.cod j"]
                                χ.A.map_simp
                          by auto
                        moreover have "S.Fun (YoD.at a' (map o χ) j) (S.Fun f' e) =
                                       S.Fun (σ j) e"
                          using Fun_map_a_a' a a' j f' e x Yoχ_a'.A.map_simp eval_at_ide
                                Yoχ_a'.cone_axioms
                          by auto
                        ultimately show ?thesis
                          using a a' Hom.ψ_φ by auto
                      qed
                      also have "... = χ j  ψ (a', a) (S.Fun ?f e)"
                      proof -
                        have "S.Fun (YoD.at a' (map o χ) j) (S.Fun ?f e) =
                                φ (a', D (J.cod j)) (χ j  ψ (a', a) (S.Fun ?f e))"
                          using j a a' fe A [of (a', a) (S.Fun ?f e)" j] Hom.φ_ψ Hom.ψ_mapsto
                          by auto
                        hence (a', D (J.cod j)) (S.Fun (YoD.at a' (map o χ) j) (S.Fun ?f e)) =
                                ψ (a', D (J.cod j))
                                  (φ (a', D (J.cod j)) (χ j  ψ (a', a) (S.Fun ?f e)))"
                          by simp
                        moreover have "χ j  ψ (a', a) (S.Fun ?f e)  C.hom a' (D (J.cod j))"
                          using a a' j fe Hom.ψ_mapsto χ.preserves_hom [of j "J.dom j" "J.cod j"]
                                χ.A.map_simp
                          by auto
                        moreover have "S.Fun (YoD.at a' (map o χ) j) (S.Fun ?f e) =
                                       S.Fun (σ j) e"
                        proof -
                          have "S.Fun (YoD.at a' (map o χ) j) (S.Fun ?f e)
                                  = (S.Fun (YoD.at a' (map o χ) j) o S.Fun ?f) e"
                            by simp
                          also have "... = S.Fun (YoD.at a' (map o χ) j S ?f) e"
                            using Fun_map_a_a' a a' j f e x Yoχ_a'.A.map_simp eval_at_ide
                            by auto
                          also have "... = S.Fun (σ j) e"
                          proof -
                            have "YoD.at a' (map o χ) j S ?f =
                                  YoD_a'.cones_map ?f (YoD.at a' (map o χ)) j"
                              using j f Yoχ_a'.cone_axioms Fun_map_a_a' by auto
                            thus ?thesis using j ff by argo
                          qed
                          finally show ?thesis by auto
                        qed
                        ultimately show ?thesis
                          using a a' Hom.ψ_φ by auto
                      qed
                      also have "... = D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
                        using j 2 χ.cone_axioms by force
                      finally show "D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
                                    D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
                        by auto
                    qed
                    ultimately show "D.cones_map (ψ (a', a) (S.Fun f' e)) χ j =
                                     D.cones_map (ψ (a', a) (S.Fun ?f e)) χ j"
                      by auto
                  qed
                  hence (a', a) (S.Fun f' e) = ψ (a', a) (S.Fun ?f e)"
                    using 1 2 χofe.cone_axioms χ.cone_axioms χ.is_universal by blast
                  hence "φ (a', a) (ψ (a', a) (S.Fun f' e)) = φ (a', a) (ψ (a', a) (S.Fun ?f e))"
                    by simp
                  thus "S.Fun f' e = S.Fun ?f e"
                    using a a' fe f'e Hom.φ_ψ by force
                qed
                ultimately show "S.Fun f' e = S.Fun ?f e" by auto
              qed
            qed
          qed
          ultimately have "∃!f. «f : x S Hom.map (a', a)» 
                                YoD_a'.cones_map f (YoD.at a' (map o χ)) = σ"
            using ex1I [of "λf. S.in_hom x (Hom.map (a', a)) f 
                                YoD_a'.cones_map f (YoD.at a' (map o χ)) = σ"]
            by blast
          thus "∃!f. «f : x S Cop_S.Map (map a) a'» 
                     YoD_a'.cones_map f (YoD.at a' (map o χ)) = σ"
            using a a' Y_def by simp
        qed
      qed
      thus "YoD.has_as_limit (map a)"
        using YoD.cone_is_limit_if_pointwise_limit Yoχ.cone_axioms by auto
    qed

  end

end

Theory Subcategory

(*  Title:       Subcategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Subcategory"

  text‹
    In this chapter we give a construction of the subcategory of a category
    defined by a predicate on arrows subject to closure conditions.  The arrows of
    the subcategory are directly identified with the arrows of the ambient category.
    We also define the related notions of full subcategory and inclusion functor.
›

theory Subcategory
imports Functor
begin

  locale subcategory =
    C: category C
    for C :: "'a comp"      (infixr "C" 55)
    and Arr :: "'a  bool" +
    assumes inclusion: "Arr f  C.arr f"
    and dom_closed: "Arr f  Arr (C.dom f)"
    and cod_closed: "Arr f  Arr (C.cod f)"
    and comp_closed: " Arr f; Arr g; C.cod f = C.dom g   Arr (g C f)"
  begin

    no_notation C.in_hom    ("«_ : _  _»")
    notation C.in_hom       ("«_ : _ C _»")

    definition comp         (infixr "" 55)
    where "g  f = (if Arr f  Arr g  C.cod f = C.dom g then g C f else C.null)"

    interpretation partial_magma comp
    proof
      show "∃!n. f. n  f = n  f  n = n"
      proof
        show 1: "f. C.null  f = C.null  f  C.null = C.null"
          by (metis C.comp_null(1) C.ex_un_null comp_def)
        show "n. f. n  f = n  f  n = n  n = C.null"
          using 1 C.ex_un_null by metis
      qed
    qed

    lemma null_char [simp]:
    shows "null = C.null"
    proof -
      have "f. C.null  f = C.null  f  C.null = C.null"
        by (metis C.comp_null(1) C.ex_un_null comp_def)
      thus ?thesis using ex_un_null by (metis comp_null(2))
    qed

    lemma ideI:
    assumes "Arr a" and "C.ide a"
    shows "ide a"
      unfolding ide_def
      using assms null_char C.ide_def comp_def by auto

    lemma Arr_iff_dom_in_domain:
    shows "Arr f  C.dom f  domains f"
    proof
      show "C.dom f  domains f  Arr f"
        using domains_def comp_def ide_def by fastforce
      show "Arr f  C.dom f  domains f"
      proof -
        assume f: "Arr f"
        have "ide (C.dom f)"
          using f inclusion C.dom_in_domains C.has_domain_iff_arr C.domains_def
                dom_closed ideI
          by auto
        moreover have "f  C.dom f  null"
          using f comp_def dom_closed null_char inclusion C.comp_arr_dom by force
        ultimately show ?thesis
          using domains_def by simp
      qed
    qed

    lemma Arr_iff_cod_in_codomain:
    shows "Arr f  C.cod f  codomains f"
    proof
      show "C.cod f  codomains f  Arr f"
        using codomains_def comp_def ide_def by fastforce
      show "Arr f  C.cod f  codomains f"
      proof -
        assume f: "Arr f"
        have "ide (C.cod f)"
          using f inclusion C.cod_in_codomains C.has_codomain_iff_arr C.codomains_def
                cod_closed ideI
          by auto
        moreover have "C.cod f  f  null"
          using f comp_def cod_closed null_char inclusion C.comp_cod_arr by force
        ultimately show ?thesis
          using codomains_def by simp
      qed
    qed

    lemma arr_char:
    shows "arr f  Arr f"
    proof
      show "Arr f  arr f"
        using arr_def comp_def Arr_iff_dom_in_domain Arr_iff_cod_in_codomain by auto
      show "arr f  Arr f"
      proof -
        assume f: "arr f"
        obtain a where a: "a  domains f  a  codomains f"
          using f arr_def by auto
        have "f  a  C.null  a  f  C.null"
          using a domains_def codomains_def null_char by auto
        thus "Arr f"
          using comp_def by metis
      qed
    qed

    lemma arrI [intro]:
    assumes "Arr f"
    shows "arr f"
      using assms arr_char by simp

    lemma arrE [elim]:
    assumes "arr f"
    shows "Arr f"
      using assms arr_char by simp

    interpretation category comp
      using comp_def null_char inclusion comp_closed dom_closed cod_closed
      apply unfold_locales
           apply auto[1]
          apply (metis Arr_iff_dom_in_domain Arr_iff_cod_in_codomain arr_char arr_def emptyE)
    proof -
      fix f g h
      assume gf: "seq g f" and hg: "seq h g"
      show 1: "seq (h  g) f"
        using gf hg inclusion comp_closed comp_def by auto
      show "(h  g)  f = h  g  f"
        using gf hg 1 C.not_arr_null inclusion comp_def arr_char
        by (metis (full_types) C.cod_comp C.comp_assoc)
      next
      fix f g h
      assume hg: "seq h g" and hgf: "seq (h  g) f"
      show "seq g f"
        using hg hgf comp_def null_char inclusion arr_char comp_closed
        by (metis (full_types) C.dom_comp)
      next
      fix f g h
      assume hgf: "seq h (g  f)" and gf: "seq g f"
      show "seq h g"
        using hgf gf comp_def null_char arr_char comp_closed
        by (metis C.seqE C.ext C.match_2)
    qed

    theorem is_category:
    shows "category comp" ..

    notation in_hom     ("«_ : _  _»")

    lemma dom_simp:
    assumes "arr f"
    shows "dom f = C.dom f"
    proof -
      have "ide (C.dom f)"
        using assms ideI
        by (meson C.ide_dom arr_char dom_closed inclusion)
      moreover have "f  C.dom f  null"
        using assms inclusion comp_def null_char dom_closed not_arr_null C.comp_arr_dom arr_char
        by auto
      ultimately show ?thesis
        using dom_eqI ext by blast
    qed

    lemma dom_char:
    shows "dom f = (if arr f then C.dom f else C.null)"
      using dom_simp dom_def arr_def arr_char by auto

    lemma cod_simp:
    assumes "arr f"
    shows "cod f = C.cod f"
    proof -
      have "ide (C.cod f)"
        using assms ideI
        by (meson C.ide_cod arr_char cod_closed inclusion)
      moreover have "C.cod f  f  null"
        using assms inclusion comp_def null_char cod_closed not_arr_null C.comp_cod_arr arr_char
        by auto
      ultimately show ?thesis
        using cod_eqI ext by blast
    qed

    lemma cod_char:
    shows "cod f = (if arr f then C.cod f else C.null)"
      using cod_simp cod_def arr_def by auto

    lemma in_hom_char:
    shows "«f : a  b»  arr a  arr b  arr f  «f : a C b»"
      using inclusion arr_char cod_closed dom_closed
      by (metis C.arr_iff_in_hom C.in_homE arr_iff_in_hom cod_simp dom_simp in_homE)

    lemma ide_char:
    shows "ide a  arr a  C.ide a"
      using ide_in_hom C.ide_in_hom in_hom_char by simp

    lemma seq_char:
    shows "seq g f  arr f  arr g  C.seq g f"
    proof
      show "arr f  arr g  C.seq g f  seq g f"
        using arr_char dom_char cod_char by (intro seqI, auto)
      show "seq g f  arr f  arr g  C.seq g f"
        apply (elim seqE, auto)
        using inclusion arr_char dom_simp cod_simp by auto
    qed

    lemma hom_char:
    shows "hom a b = C.hom a b  Collect Arr"
    proof
      show "hom a b  C.hom a b  Collect Arr"
        using in_hom_char by auto
      show "C.hom a b  Collect Arr  hom a b"
        using arr_char dom_char cod_char by force
    qed

    lemma comp_char:
    shows "g  f = (if arr f  arr g  C.seq g f then g C f else C.null)"
      using arr_char comp_def comp_closed C.ext by force

    lemma comp_simp:
    assumes "seq g f"
    shows "g  f = g C f"
      using assms comp_char seq_char by metis

    lemma inclusion_preserves_inverse:
    assumes "inverse_arrows f g"
    shows "C.inverse_arrows f g"
      using assms ide_char comp_simp arr_char
      by (intro C.inverse_arrowsI, auto)

    lemma iso_char:
    shows "iso f  C.iso f  arr f  arr (C.inv f)"
    proof
      assume f: "iso f"
      show "C.iso f  arr f  arr (C.inv f)"
      proof -
        have 1: "inverse_arrows f (inv f)"
          using f inv_is_inverse by auto
        have 2: "C.inverse_arrows f (inv f)"
          using 1 inclusion_preserves_inverse by blast
        moreover have "arr (inv f)"
          using 1 iso_is_arr by blast
        moreover have "inv f = C.inv f"
          using 1 2 C.inv_is_inverse C.inverse_arrow_unique by blast
        ultimately show ?thesis using f 2 iso_is_arr by auto
      qed
      next
      assume f: "C.iso f  arr f  arr (C.inv f)"
      show "iso f"
      proof
        have 1: "C.inverse_arrows f (C.inv f)"
          using f C.inv_is_inverse by blast
        show "inverse_arrows f (C.inv f)"
        proof
          have 2: "C.inv f  f = C.inv f C f  f  C.inv f = f C C.inv f"
            using f 1 comp_char by fastforce
          have 3: "antipar f (C.inv f)"
            using f C.seqE seqI dom_simp cod_simp by simp
          show "ide (C.inv f  f)"
            using 1 2 3 ide_char apply (elim C.inverse_arrowsE) by simp
          show "ide (f  C.inv f)"
            using 1 2 3 ide_char apply (elim C.inverse_arrowsE) by simp
        qed
      qed
    qed

    lemma inv_char:
    assumes "iso f"
    shows "inv f = C.inv f"
    proof -
      have "C.inverse_arrows f (inv f)"
      proof
        have 1: "inverse_arrows f (inv f)"
          using assms iso_char inv_is_inverse by blast
        show "C.ide (inv f C f)"
        proof -
          have "inv f  f = inv f C f"
            using assms 1 inv_in_hom iso_char [of f] comp_char [of "inv f" f] seq_char by auto
          thus ?thesis
            using 1 ide_char arr_char by force
        qed
        show "C.ide (f C inv f)"
        proof -
          have "f  inv f = f C inv f"
            using assms 1 inv_in_hom iso_char [of f] comp_char [of f "inv f"] seq_char by auto
          thus ?thesis
            using 1 ide_char arr_char by force
        qed
      qed
      thus ?thesis using C.inverse_arrow_unique C.inv_is_inverse by blast
    qed

  end

  sublocale subcategory  category comp
    using is_category by auto

  section "Full Subcategory"

  locale full_subcategory =
    C: category C
    for C :: "'a comp"
    and Ide :: "'a  bool" +
    assumes inclusion: "Ide f  C.ide f"

  sublocale full_subcategory  subcategory C "λf. C.arr f  Ide (C.dom f)  Ide (C.cod f)"
      by (unfold_locales; simp)

  context full_subcategory
  begin

    text ‹
      Isomorphisms in a full subcategory are inherited from the ambient category.
›

    lemma iso_char:
    shows "iso f  arr f  C.iso f"
    proof
      assume f: "iso f"
      obtain g where g: "inverse_arrows f g" using f by blast
      show "arr f  C.iso f"
      proof -
        have "C.inverse_arrows f g"
          using g apply (elim inverse_arrowsE, intro C.inverse_arrowsI)
          using comp_simp ide_char arr_char by auto
        thus ?thesis
          using f iso_is_arr by blast
      qed
      next
      assume f: "arr f  C.iso f"
      obtain g where g: "C.inverse_arrows f g" using f by blast
      have "inverse_arrows f g"
      proof
        show "ide (comp g f)"
          using f g
          by (metis (no_types, lifting) C.seqE C.ide_compE C.inverse_arrowsE
              arr_char dom_simp ide_dom comp_def)
        show "ide (comp f g)"
          using f g C.inverse_arrows_sym [of f g]
          by (metis (no_types, lifting) C.seqE C.ide_compE C.inverse_arrowsE
              arr_char dom_simp ide_dom comp_def)
      qed
      thus "iso f" by auto
    qed

  end

  section "Inclusion Functor"

  text ‹
    If S› is a subcategory of C›, then there is an inclusion functor
    from S› to C›.  Inclusion functors are faithful embeddings.
›

  locale inclusion_functor =
    C: category C +
    S: subcategory C Arr
  for C :: "'a comp"
  and Arr :: "'a  bool"
  begin

    interpretation "functor" S.comp C S.map
      using S.map_def S.arr_char S.inclusion S.dom_char S.cod_char
            S.dom_closed S.cod_closed S.comp_closed S.arr_char S.comp_char
      apply unfold_locales
          apply auto[4]
      by (elim S.seqE, auto)

    lemma is_functor:
    shows "functor S.comp C S.map" ..

    interpretation faithful_functor S.comp C S.map
      apply unfold_locales by simp

    lemma is_faithful_functor:
    shows "faithful_functor S.comp C S.map" ..

    interpretation embedding_functor S.comp C S.map
      apply unfold_locales by simp

    lemma is_embedding_functor:
    shows "embedding_functor S.comp C S.map" ..

  end

  sublocale inclusion_functor  faithful_functor S.comp C S.map
    using is_faithful_functor by auto
  sublocale inclusion_functor  embedding_functor S.comp C S.map
    using is_embedding_functor by auto

  text ‹
    The inclusion of a full subcategory is a special case.
    Such functors are fully faithful.
›

  locale full_inclusion_functor =
    C: category C +
    S: full_subcategory C Ide
  for C :: "'a comp"
  and Ide :: "'a  bool"

  sublocale full_inclusion_functor 
              inclusion_functor C "λf. C.arr f  Ide (C.dom f)  Ide (C.cod f)" ..

  context full_inclusion_functor
  begin

    interpretation full_functor S.comp C S.map
      apply unfold_locales
      using S.ide_in_hom
      by (metis (no_types, lifting) C.in_homE S.arr_char S.in_hom_char S.map_simp)

    lemma is_full_functor:
    shows "full_functor S.comp C S.map" ..

  end

  sublocale full_inclusion_functor  full_functor S.comp C S.map
    using is_full_functor by auto
  sublocale full_inclusion_functor  fully_faithful_functor S.comp C S.map ..

end

Theory EquivalenceOfCategories

(*  Title:       EquivalenceOfCategories
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Equivalence of Categories"

text ‹
  In this chapter we define the notions of equivalence and adjoint equivalence of categories
  and establish some properties of functors that are part of an equivalence.
›

theory EquivalenceOfCategories
imports Adjunction
begin

  locale equivalence_of_categories =
    C: category C +
    D: category D +
    F: "functor" D C F +
    G: "functor" C D G +
    η: natural_isomorphism D D D.map "G o F" η +
    ε: natural_isomorphism C C "F o G" C.map ε
  for C :: "'c comp"     (infixr "C" 55)
  and D :: "'d comp"     (infixr "D" 55)
  and F :: "'d  'c"
  and G :: "'c  'd"
  and η :: "'d  'd"
  and ε :: "'c  'c"
  begin

    notation C.in_hom    ("«_ : _ C _»")
    notation D.in_hom    ("«_ : _ D _»")

    lemma C_arr_expansion:
    assumes "C.arr f"
    shows "ε (C.cod f) C F (G f) C C.inv (ε (C.dom f)) = f"
    and "C.inv (ε (C.cod f)) C f C ε (C.dom f) = F (G f)"
    proof -
      have ε_dom: "C.inverse_arrows (ε (C.dom f)) (C.inv (ε (C.dom f)))"
        using assms C.inv_is_inverse by auto
      have ε_cod: "C.inverse_arrows (ε (C.cod f)) (C.inv (ε (C.cod f)))"
        using assms C.inv_is_inverse by auto
      have "ε (C.cod f) C F (G f) C C.inv (ε (C.dom f)) =
            (ε (C.cod f) C F (G f)) C C.inv (ε (C.dom f))"
        using C.comp_assoc by force
      also have 1: "... = (f C ε (C.dom f)) C C.inv (ε (C.dom f))"
        using assms ε.naturality by simp
      also have 2: "... = f"
        using assms ε_dom C.comp_arr_inv C.comp_arr_dom C.comp_assoc by force
      finally show "ε (C.cod f) C F (G f) C C.inv (ε (C.dom f)) = f" by blast
      show "C.inv (ε (C.cod f)) C f C ε (C.dom f) = F (G f)"
        using assms 1 2 ε_dom ε_cod C.invert_side_of_triangle C.isoI C.iso_inv_iso
        by metis
    qed

    lemma G_is_faithful:
    shows "faithful_functor C D G"
    proof
      fix f f'
      assume par: "C.par f f'" and eq: "G f = G f'"
      show "f = f'"
      proof -
        have "C.inv (ε (C.cod f))  C.hom (C.cod f) (F (G (C.cod f))) 
              C.iso (C.inv (ε (C.cod f)))"
          using par by auto
        moreover have 1: "ε (C.dom f)  C.hom (F (G (C.dom f))) (C.dom f) 
                          C.iso (ε (C.dom f))"
          using par by auto
        ultimately have 2: "f C ε (C.dom f) = f' C ε (C.dom f)"
          using par C_arr_expansion eq C.iso_is_section C.section_is_mono
          by (metis C_arr_expansion(1) eq)
        show ?thesis
        proof -
          have "C.epi (ε (C.dom f))"
            using 1 par C.iso_is_retraction C.retraction_is_epi by blast
          thus ?thesis using 2 par by auto
        qed
      qed
    qed

    lemma G_is_essentially_surjective:
    shows "essentially_surjective_functor C D G"
    proof
      fix b
      assume b: "D.ide b"
      have "C.ide (F b)  D.isomorphic (G (F b)) b"
      proof
        show "C.ide (F b)" using b by simp
        show "D.isomorphic (G (F b)) b"
        proof (unfold D.isomorphic_def)
          have "«D.inv (η b) : G (F b) D b»  D.iso (D.inv (η b))"
            using b by auto
          thus "f. «f : G (F b) D b»  D.iso f" by blast
        qed
      qed
      thus "a. C.ide a  D.isomorphic (G a) b"
        by blast
    qed

    interpretation ε_inv: inverse_transformation C C F o G C.map ε ..
    interpretation η_inv: inverse_transformation D D D.map G o F η ..
    interpretation GF: equivalence_of_categories D C G F ε_inv.map η_inv.map ..

    lemma F_is_faithful:
    shows "faithful_functor D C F"
      using GF.G_is_faithful by simp

    lemma F_is_essentially_surjective:
    shows "essentially_surjective_functor D C F"
      using GF.G_is_essentially_surjective by simp

    lemma G_is_full:
    shows "full_functor C D G"
    proof
      fix a a' g
      assume a: "C.ide a" and a': "C.ide a'"
      assume g: "«g : G a D G a'»"
      show "f. «f : a C a'»  G f = g"
      proof
        have εa: "C.inverse_arrows (ε a) (C.inv (ε a))"
          using a C.inv_is_inverse by auto
        have εa': "C.inverse_arrows (ε a') (C.inv (ε a'))"
          using a' C.inv_is_inverse by auto
        let ?f = "ε a' C F g C C.inv (ε a)"
        have f: "«?f : a C a'»"
          using a a' g εa εa' ε.preserves_hom [of a' a' a'] ε_inv.preserves_hom [of a a a]
          by fastforce
        moreover have "G ?f = g"
        proof -
          interpret F: faithful_functor D C F
            using F_is_faithful by auto
          have "F (G ?f) = F g"
          proof -
            have "F (G ?f) = C.inv (ε a') C ?f C ε a"
              using f C_arr_expansion(2) [of "?f"] by auto
            also have "... = (C.inv (ε a') C ε a') C F g C C.inv (ε a) C ε a"
              using a a' f g C.comp_assoc by fastforce
            also have "... = F g"
              using a a' g εa εa' C.comp_inv_arr C.comp_arr_dom C.comp_cod_arr by auto
            finally show ?thesis by blast
          qed
          moreover have "D.par (G (ε a' C F g C C.inv (ε a))) g"
            using f g by fastforce
          ultimately show ?thesis using f g F.is_faithful by blast
        qed
        ultimately show "«?f : a C a'»  G ?f = g" by blast
      qed
    qed

  end

  (* I'm not sure why I had to close and re-open the context here in order to
   * get the G_is_full fact in the interpretation GF. *)

  context equivalence_of_categories
  begin

    interpretation ε_inv: inverse_transformation C C F o G C.map ε ..
    interpretation η_inv: inverse_transformation D D D.map G o F η ..
    interpretation GF: equivalence_of_categories D C G F ε_inv.map η_inv.map ..

    lemma F_is_full:
    shows "full_functor D C F"
      using GF.G_is_full by simp

  end

  text ‹
    Traditionally the term "equivalence of categories" is also used for a functor
    that is part of an equivalence of categories.  However, it seems best to use
    that term for a situation in which all of the structure of an equivalence is
    explicitly given, and to have a different term for one of the functors involved.
›

  locale equivalence_functor =
    C: category C +
    D: category D +
    "functor" C D G
  for C :: "'c comp"     (infixr "C" 55)
  and D :: "'d comp"     (infixr "D" 55)
  and G :: "'c  'd" +
  assumes induces_equivalence: "F η ε. equivalence_of_categories C D F G η ε"
  begin

    notation C.in_hom    ("«_ : _ C _»")
    notation D.in_hom    ("«_ : _ D _»")

  end

  sublocale equivalence_of_categories  equivalence_functor C D G
    using equivalence_of_categories_axioms by (unfold_locales, blast)

  text ‹
    An equivalence functor is fully faithful and essentially surjective.
›

  sublocale equivalence_functor  fully_faithful_functor C D G
  proof -
    obtain F η ε where 1: "equivalence_of_categories C D F G η ε"
      using induces_equivalence by blast
    interpret equivalence_of_categories C D F G η ε
      using 1 by auto
    show "fully_faithful_functor C D G"
      using G_is_full G_is_faithful fully_faithful_functor.intro by auto
  qed

  sublocale equivalence_functor  essentially_surjective_functor C D G
  proof -
    obtain F η ε where 1: "equivalence_of_categories C D F G η ε"
      using induces_equivalence by blast
    interpret equivalence_of_categories C D F G η ε
      using 1 by auto
    show "essentially_surjective_functor C D G"
      using G_is_essentially_surjective by auto
  qed

  text ‹
    A special case of an equivalence functor is an endofunctor F› equipped with
    a natural isomorphism from F› to the identity functor.
›

  context endofunctor
  begin

    lemma isomorphic_to_identity_is_equivalence:
    assumes "natural_isomorphism A A F A.map φ"
    shows "equivalence_functor A A F"
    proof -
      interpret φ: natural_isomorphism A A F A.map φ
         using assms by auto
      interpret φ': inverse_transformation A A F A.map φ ..
      interpret Fφ': natural_isomorphism A A F F o F F o φ'.map›
      proof -
        interpret Fφ': natural_transformation A A F F o F F o φ'.map›
          using φ'.natural_transformation_axioms functor_axioms
                horizontal_composite [of A A A.map F φ'.map A F F F]
          by simp
        show "natural_isomorphism A A F (F o F) (F o φ'.map)"
          apply unfold_locales
          using φ'.components_are_iso by fastforce
      qed
      interpret Fφ'oφ': vertical_composite A A A.map F F o F φ'.map F o φ'.map› ..
      interpret Fφ'oφ': natural_isomorphism A A A.map F o F Fφ'oφ'.map
        using φ'.natural_isomorphism_axioms Fφ'.natural_isomorphism_axioms
              natural_isomorphisms_compose
        by fast
      interpret inv_Fφ'oφ': inverse_transformation A A A.map F o F Fφ'oφ'.map ..
      interpret F: equivalence_of_categories A A F F Fφ'oφ'.map inv_Fφ'oφ'.map ..
      show ?thesis ..
    qed

  end

  text ‹
    An adjoint equivalence is an equivalence of categories that is also an adjunction.
›

  locale adjoint_equivalence =
    unit_counit_adjunction C D F G η ε +
    η: natural_isomorphism D D D.map "G o F" η +
    ε: natural_isomorphism C C "F o G" C.map ε
  for C :: "'c comp"     (infixr "C" 55)
  and D :: "'d comp"     (infixr "D" 55)
  and F :: "'d  'c"
  and G :: "'c  'd"
  and η :: "'d  'd"
  and ε :: "'c  'c"

  text ‹
    An adjoint equivalence is clearly an equivalence of categories.
›

  sublocale adjoint_equivalence  equivalence_of_categories ..

  context adjoint_equivalence
  begin

    text ‹
      The triangle identities for an adjunction reduce to inverse relations when
      η› and ε› are natural isomorphisms.
›

    lemma triangle_G':
    assumes "C.ide a"
    shows "D.inverse_arrows (η (G a)) (G (ε a))"
    proof
      show "D.ide (G (ε a) D η (G a))"
        using assms triangle_G GεoηG.map_simp_ide by fastforce
      thus "D.ide (η (G a) D G (ε a))"
        using assms D.section_retraction_of_iso [of "G (ε a)" "η (G a)"] by auto
    qed

    lemma triangle_F':
    assumes "D.ide b"
    shows "C.inverse_arrows (F (η b)) (ε (F b))"
    proof
     show "C.ide (ε (F b) C F (η b))"
        using assms triangle_F εFoFη.map_simp_ide by auto
      thus "C.ide (F (η b) C ε (F b))"
        using assms C.section_retraction_of_iso [of "ε (F b)" "F (η b)"] by auto
    qed

    text ‹
      An adjoint equivalence can be dualized by interchanging the two functors and inverting
      the natural isomorphisms.  This is somewhat awkward to prove, but probably useful to have
      done it once and for all.
›

    lemma dual_equivalence:
    assumes "adjoint_equivalence C D F G η ε"
    shows "adjoint_equivalence D C G F (inverse_transformation.map C C (C.map) ε)
                                       (inverse_transformation.map D D (G o F) η)"
    proof -
      interpret adjoint_equivalence C D F G η ε using assms by auto
      interpret ε': inverse_transformation C C F o G C.map ε ..
      interpret η': inverse_transformation D D D.map G o F η ..
      interpret Gε': natural_transformation C D G G o F o G G o ε'.map›
      proof -
        have "natural_transformation C D G (G o (F o G)) (G o ε'.map)"
          using G.natural_transformation_axioms ε'.natural_transformation_axioms
                horizontal_composite
          by fastforce
        thus "natural_transformation C D G (G o F o G) (G o ε'.map)"
          using o_assoc by metis
      qed
      interpret η'G: natural_transformation C D G o F o G G ‹η'.map o G
        using η'.natural_transformation_axioms G.natural_transformation_axioms
              horizontal_composite
        by fastforce
      interpret ε'F: natural_transformation D C F F o G o F ‹ε'.map o F
        using ε'.natural_transformation_axioms F.natural_transformation_axioms
              horizontal_composite
        by fastforce
      interpret Fη': natural_transformation D C F o G o F F F o η'.map›
      proof -
        have "natural_transformation D C (F o (G o F)) F (F o η'.map)"
          using η'.natural_transformation_axioms F.natural_transformation_axioms
                horizontal_composite
          by fastforce
        thus "natural_transformation D C (F o G o F) F (F o η'.map)"
          using o_assoc by metis
      qed
      interpret Fη'oε'F: vertical_composite D C F (F o G) o F F ‹ε'.map o F F o η'.map› ..
      interpret η'GoGε': vertical_composite C D G G o F o G G G o ε'.map› ‹η'.map o G ..
      show ?thesis
      proof
        show "η'GoGε'.map = G"
        proof (intro NaturalTransformation.eqI)
          show "natural_transformation C D G G G"
            using G.natural_transformation_axioms by auto
          show "natural_transformation C D G G η'GoGε'.map"
            using η'GoGε'.natural_transformation_axioms by auto
          show "a. C.ide a  η'GoGε'.map a = G a"
          proof -
            fix a
            assume a: "C.ide a"
            show "η'GoGε'.map a = G a"
              using a η'GoGε'.map_simp_ide triangle_G'
                    η.components_are_iso ε.components_are_iso G.preserves_ide
                    η'.inverts_components ε'.inverts_components
                    D.inverse_unique G.preserves_inverse_arrows GεoηG.map_simp_ide
                    D.inverse_arrows_sym triangle_G
              by (metis o_apply)
          qed
        qed
        show "Fη'oε'F.map = F"
        proof (intro NaturalTransformation.eqI)
          show "natural_transformation D C F F F"
            using F.natural_transformation_axioms by auto
          show "natural_transformation D C F F Fη'oε'F.map"
            using Fη'oε'F.natural_transformation_axioms by auto
          show "b. D.ide b  Fη'oε'F.map b = F b"
          proof -
            fix b
            assume b: "D.ide b"
            show "Fη'oε'F.map b = F b"
              using b Fη'oε'F.map_simp_ide εFoFη.map_simp_ide triangle_F triangle_F'
                    η.components_are_iso ε.components_are_iso G.preserves_ide
                    η'.inverts_components ε'.inverts_components F.preserves_ide
                    C.inverse_unique F.preserves_inverse_arrows C.inverse_arrows_sym
              by (metis o_apply)
          qed
        qed
      qed
    qed

  end

  text ‹
    Every fully faithful and essentially surjective functor underlies an adjoint equivalence.
    To prove this without repeating things that were already proved in @{theory Category3.Adjunction},
    we first show that a fully faithful and essentially surjective functor is a left adjoint
    functor, and then we show that if the left adjoint in a unit-counit adjunction is
    fully faithful and essentially surjective, then the unit and counit are natural isomorphisms;
    hence the adjunction is in fact an adjoint equivalence.
›

  locale fully_faithful_and_essentially_surjective_functor =
    C: category C +
    D: category D +
    fully_faithful_functor C D F +
    essentially_surjective_functor C D F
    for C :: "'c comp"     (infixr "C" 55)
    and D :: "'d comp"     (infixr "D" 55)
    and F :: "'c  'd"
  begin

    notation C.in_hom      ("«_ : _ C _»")
    notation D.in_hom      ("«_ : _ D _»")

    lemma is_left_adjoint_functor:
    shows "left_adjoint_functor C D F"
    proof
      fix y
      assume y: "D.ide y"
      let ?x = "SOME x. C.ide x  (e. D.iso e  «e : F x D y»)"
      let ?e = "SOME e. D.iso e  «e : F ?x D y»"
      have "x e. D.iso e  terminal_arrow_from_functor C D F x y e"
      proof -
        have "x. D.iso ?e  terminal_arrow_from_functor C D F x y ?e"
        proof -
          have x: "C.ide ?x  (e. D.iso e  «e : F ?x D y»)"
            using y essentially_surjective
                  someI_ex [of "λx. C.ide x  (e. D.iso e  «e : F x D y»)"]
            by blast
          hence e: "D.iso ?e  «?e : F ?x D y»"
            using someI_ex [of "λe. D.iso e  «e : F ?x D y»"] by blast
          interpret arrow_from_functor C D F ?x y ?e
            using x e by (unfold_locales, simp)
          interpret terminal_arrow_from_functor C D F ?x y ?e
          proof
            fix x' f
            assume 1: "arrow_from_functor C D F x' y f"
            interpret f: arrow_from_functor C D F x' y f
              using 1 by simp
            have f: "«f: F x' D y»"
              by (meson f.arrow)
            show "∃!g. is_coext x' f g"
            proof
              let ?g = "SOME g. «g : x' C ?x»  F g = D.inv ?e D f"
              have g: "«?g : x' C ?x»  F ?g = D.inv ?e D f"
                using f e x f.arrow is_full D.comp_in_homI D.inv_in_hom
                      someI_ex [of "λg. «g : x' C ?x»  F g = D.inv ?e D f"]
                by auto
              show 1: "is_coext x' f ?g"
              proof -
                have "«?g : x' C ?x»"
                  using g by simp
                moreover have "?e D F ?g = f"
                proof -
                  have "?e D F ?g = ?e D D.inv ?e D f"
                    using g by simp
                  also have "... = (?e D D.inv ?e) D f"
                    using e f D.inv_in_hom by (metis D.comp_assoc)
                  also have "... = f"
                  proof -
                    have "?e D D.inv ?e = y"
                      using e D.comp_arr_inv D.inv_is_inverse by auto
                    thus ?thesis
                      using f D.comp_cod_arr by auto
                  qed
                  finally show ?thesis by blast
                qed
                ultimately show ?thesis
                  unfolding is_coext_def by simp
              qed
              show "g'. is_coext x' f g'  g' = ?g"
              proof -
                fix g'
                assume g': "is_coext x' f g'"
                have 2: "«g' : x' C ?x»  ?e D F g' = f" using g' is_coext_def by simp
                have 3: "«?g : x' C ?x»  ?e D F ?g = f" using 1 is_coext_def by simp
                have "F g' = F ?g"
                  using e 2 3 D.iso_is_section D.section_is_mono D.monoE by blast
                moreover have "C.par g' ?g"
                  using 2 3 by fastforce
                ultimately show "g' = ?g"
                  using is_faithful [of g' ?g] by simp
              qed
            qed
          qed
          show ?thesis
            using e terminal_arrow_from_functor_axioms by auto
        qed
        thus ?thesis by auto
      qed
      thus "x e. terminal_arrow_from_functor C D F x y e" by blast
    qed

    lemma extends_to_adjoint_equivalence:
    shows "G η ε. adjoint_equivalence C D G F η ε"
    proof -
      interpret left_adjoint_functor C D F
        using is_left_adjoint_functor by blast
      interpret Adj: meta_adjunction D C F G φ ψ
        using induces_meta_adjunction by simp
      interpret Adj: adjunction D C replete_setcat.comp
                       Adj.φC Adj.φD F G φ ψ Adj.η Adj.ε Adj.Φ Adj.Ψ
        using induces_adjunction by simp
      interpret equivalence_of_categories D C F G Adj.η Adj.ε
      proof
        show 1: "a. D.ide a  D.iso (Adj.ε a)"
        proof -
          fix a
          assume a: "D.ide a"
          interpret εa: terminal_arrow_from_functor C D F ‹G a a ‹Adj.ε a
            using a Adj.has_terminal_arrows_from_functor [of a] by blast
          have "D.retraction (Adj.ε a)"
          proof -
            obtain b φ where φ: "C.ide b  D.iso φ  «φ: F b D a»"
              using a essentially_surjective by blast
            interpret φ: arrow_from_functor C D F b a φ
              using φ by (unfold_locales, simp)
            let ?g = "εa.the_coext b φ"
            have 1: "«?g : b C G a»  Adj.ε a D F ?g = φ"
              using φ.arrow_from_functor_axioms εa.the_coext_prop [of b φ] by simp
            have "a = (Adj.ε a D F ?g) D D.inv φ"
              using a 1 φ D.comp_cod_arr Adj.ε.preserves_hom D.invert_side_of_triangle(2)
               by auto
            also have "... = Adj.ε a D F ?g D D.inv φ"
              using a 1 φ D.inv_in_hom Adj.ε.preserves_hom [of a a a] D.comp_assoc
              by blast
            finally have "f. D.ide (Adj.ε a D f)"
              using a by metis
            thus ?thesis
              unfolding D.retraction_def by blast
          qed
          moreover have "D.mono (Adj.ε a)"
          proof
            show "D.arr (Adj.ε a)"
              using a by simp
            show "f f'. D.seq (Adj.ε a) f  D.seq (Adj.ε a) f'  Adj.ε a D f = Adj.ε a D f'
                             f = f'"
            proof -
              fix f f'
              assume ff': "D.seq (Adj.ε a) f  D.seq (Adj.ε a) f'  Adj.ε a D f = Adj.ε a D f'"
              have f: "«f : D.dom f D F (G a)»"
                using a ff' Adj.ε.preserves_hom [of a a a] by fastforce
              have f': "«f' : D.dom f' D F (G a)»"
                using a ff' Adj.ε.preserves_hom [of a a a] by fastforce
              have par: "D.par f f'"
                using f f' ff' D.dom_comp [of "Adj.ε a" f] by force
              obtain b' φ where φ: "C.ide b'  D.iso φ  «φ: F b' D D.dom f»"
                using par essentially_surjective D.ide_dom [of f] by blast
              have 1: "Adj.ε a D f D φ = Adj.ε a D f' D φ"
                using ff' φ par D.comp_assoc by metis
              obtain g where g: "«g : b' C G a»  F g = f D φ"
                using a f φ is_full [of "G a" b' "f D φ"] by auto
              obtain g' where g': "«g' : b' C G a»  F g' = f' D φ"
                using a f' par φ is_full [of "G a" b' "f' D φ"] by auto
              interpret: arrow_from_functor C D F b' a ‹Adj.ε a D f D φ
                using a φ f Adj.ε.preserves_hom
                by (unfold_locales, fastforce)
              interpret f'φ: arrow_from_functor C D F b' a ‹Adj.ε a D f' D φ
                using a φ f' par Adj.ε.preserves_hom
                by (unfold_locales, fastforce)
              have "εa.is_coext b' (Adj.ε a D f D φ) g"
                unfolding εa.is_coext_def using g 1 by auto
              moreover have "εa.is_coext b' (Adj.ε a D f' D φ) g'"
                unfolding εa.is_coext_def using g' 1 by auto
              ultimately have "g = g'"
                using 1 fφ.arrow_from_functor_axioms f'φ.arrow_from_functor_axioms
                      εa.the_coext_unique εa.the_coext_unique [of b' "Adj.ε a D f' D φ" g']
                by auto
              hence "f D φ = f' D φ"
                using g g' is_faithful by argo
              thus "f = f'"
                using φ f f' par D.iso_is_retraction D.retraction_is_epi D.epiE [of φ f f']
                by auto
            qed
          qed
          ultimately show "D.iso (Adj.ε a)"
            using D.iso_iff_mono_and_retraction by simp
        qed
        interpret ε: natural_isomorphism D D F o G› D.map Adj.ε
          using 1 by (unfold_locales, auto)
        interpret εF: natural_isomorphism C D F o G o F F ‹Adj.ε o F
          using ε.components_are_iso by (unfold_locales, simp)
        show "a. C.ide a  C.iso (Adj.η a)"
        proof -
          fix a
          assume a: "C.ide a"
          have "D.inverse_arrows ((Adj.ε o F) a) ((F o Adj.η) a)"
            using a ε.components_are_iso Adj.ηε.triangle_F Adj.εFoFη.map_simp_ide
                  D.section_retraction_of_iso
            by simp
          hence "D.iso ((F o Adj.η) a)"
            by blast
          thus "C.iso (Adj.η a)"
            using a reflects_iso [of "Adj.η a"] by fastforce
        qed
      qed
      (*
       * Uggh, I should have started with "right_adjoint_functor D C G" so that the
       * following would come out right.  Instead, another step is needed to dualize.
       * TODO: Maybe re-work this later.
       *)
      interpret adjoint_equivalence D C F G Adj.η Adj.ε ..
      interpret ε': inverse_transformation D D F o G› D.map Adj.ε ..
      interpret η': inverse_transformation C C C.map ‹G o F Adj.η ..
      interpret E: adjoint_equivalence C D G F ε'.map η'.map
        using adjoint_equivalence_axioms dual_equivalence by blast
      show ?thesis
        using E.adjoint_equivalence_axioms by auto
    qed

    lemma is_right_adjoint_functor:
    shows "right_adjoint_functor C D F"
    proof -
      obtain G η ε where E: "adjoint_equivalence C D G F η ε"
        using extends_to_adjoint_equivalence by auto
      interpret E: adjoint_equivalence C D G F η ε
        using E by simp
      interpret Adj: meta_adjunction C D G F E.φ E.ψ
        using E.induces_meta_adjunction by simp
      show ?thesis
        using Adj.has_right_adjoint_functor by simp
    qed

    lemma is_equivalence_functor:
    shows "equivalence_functor C D F"
    proof
      obtain G η ε where E: "adjoint_equivalence C D G F η ε"
        using extends_to_adjoint_equivalence by auto
      interpret E: adjoint_equivalence C D G F η ε
        using E by simp
      have "equivalence_of_categories C D G F η ε" ..
      thus "G η ε. equivalence_of_categories C D G F η ε" by blast
    qed

    sublocale equivalence_functor C D F
      using is_equivalence_functor by blast

  end

  context equivalence_of_categories
  begin

    text ‹
      The following development shows that an equivalence of categories can
      be refined to an adjoint equivalence by replacing just the counit.
    ›

    abbreviation ε'
    where "ε' a  ε a C F (D.inv (η (G a))) C C.inv (ε (F (G a)))"

    interpretation ε': transformation_by_components C C F  G C.map ε'
    proof
      show "a. C.ide a  «ε' a : (F  G) a C C.map a»"
        using η.components_are_iso ε.components_are_iso by simp
      fix f
      assume f: "C.arr f"
      show "ε' (C.cod f) C (F  G) f = C.map f C ε' (C.dom f)"
      proof -
        have "ε' (C.cod f) C (F  G) f =
              ε (C.cod f) C F (D.inv (η (G (C.cod f)))) C C.inv (ε (F (G (C.cod f)))) C F (G f)"
          using f C.comp_assoc by simp
        also have "... = ε (C.cod f) C (F (D.inv (η (G (C.cod f)))) C
                           F (G (F (G f)))) C C.inv (ε (F (G (C.dom f))))"
          using f ε.inv_naturality [of "F (G f)"] C.comp_assoc by simp
        also have "... = (ε (C.cod f) C F (G f)) C F (D.inv (η (G (C.dom f)))) C
                           C.inv (ε (F (G (C.dom f))))"
        proof -
          have "F (D.inv (η (G (C.cod f)))) C F (G (F (G f))) =
                F (G f) C F (D.inv (η (G (C.dom f))))"
          proof -
            have "F (D.inv (η (G (C.cod f)))) C F (G (F (G f))) =
                  F (D.inv (η (G (C.cod f))) D G (F (G f)))"
              using f by simp
            also have "... = F (G f D D.inv (η (G (C.dom f))))"
              using f η.inv_naturality [of "G f"] by simp
            also have "... = F (G f) C F (D.inv (η (G (C.dom f))))"
              using f by simp
            finally show ?thesis by blast
          qed
          thus ?thesis
            using C.comp_assoc by simp
        qed
        also have "... = C.map f C ε (C.dom f) C F (D.inv (η (G (C.dom f)))) C
                           C.inv (ε (F (G (C.dom f))))"
          using f ε.naturality C.comp_assoc by simp
        finally show ?thesis by blast
      qed
    qed

    interpretation ε': natural_isomorphism C C F  G C.map ε'.map
    proof
      show "a. C.ide a  C.iso (ε'.map a)"
        unfolding ε'.map_def
        using η.components_are_iso ε.components_are_iso
        apply simp
        by (intro C.isos_compose) auto
    qed

    lemma Fη_inverse:
    assumes "D.ide b"
    shows "F (η (G (F b))) = F (G (F (η b)))"
    and "F (η b) C ε (F b) = ε (F (G (F b))) C F (η (G (F b)))"
    and "C.inverse_arrows (F (η b)) (ε' (F b))"
    and "F (η b) = C.inv (ε' (F b))"
    and "C.inv (F (η b)) = ε' (F b)"
    proof -
      let ?ε' = "λa. ε a C F (D.inv (η (G a))) C C.inv (ε (F (G a)))"
      show 1: "F (η (G (F b))) = F (G (F (η b)))"
      proof -
        have "F (η (G (F b))) C F (η b) = F (G (F (η b))) C F (η b)"
        proof -
          have "F (η (G (F b))) C F (η b) = F (η (G (F b)) D η b)"
            using assms by simp
          also have "... = F (G (F (η b)) D η b)"
            using assms η.naturality [of "η b"] by simp
          also have "... = F (G (F (η b))) C F (η b)"
            using assms by simp
          finally show ?thesis by blast
        qed
        thus ?thesis
          using assms η.components_are_iso C.iso_cancel_right by simp
      qed
      show "F (η b) C ε (F b) = ε (F (G (F b))) C F (η (G (F b)))"
        using assms 1 ε.naturality [of "F (η b)"] by simp
      show 2: "C.inverse_arrows (F (η b)) (?ε' (F b))"
      proof
        show 3: "C.ide (?ε' (F b) C F (η b))"
        proof -
          have "?ε' (F b) C F (η b) =
                ε (F b) C (F (D.inv (η (G (F b)))) C C.inv (ε (F (G (F b))))) C F (η b)"
            using C.comp_assoc by simp
          also have "... = ε (F b) C (F (D.inv (η (G (F b)))) C F (G (F (η b)))) C C.inv (ε (F b))"
            using assms ε.naturality [of "F (η b)"] ε.components_are_iso C.comp_assoc
                  C.invert_opposite_sides_of_square
                    [of "ε (F (G (F b)))" "F (G (F (η b)))" "F (η b)" "ε (F b)"]
            by simp
          also have "... = ε (F b) C C.inv (ε (F b))"
          proof -
            have "F (D.inv (η (G (F b)))) C F (G (F (η b))) = F (G (F b))"
              using assms 1 D.comp_inv_arr' η.components_are_iso
              by (metis D.ideD(1) D.ideD(2) F.preserves_comp
                  F.preserves_ide G.preserves_ide η.preserves_dom D.map_simp)
            moreover have "F (G (F b)) C C.inv (ε (F b)) = C.inv (ε (F b))"
              using assms D.comp_cod_arr ε.components_are_iso C.inv_in_hom [of "ε (F b)"]
              by (metis C.comp_ide_arr C_arr_expansion(1) D.ide_char F.preserves_arr
                  F.preserves_dom F.preserves_ide G.preserves_ide C.seqE)
            ultimately show ?thesis by simp
          qed
          also have "... = F b"
            using assms ε.components_are_iso C.comp_arr_inv' by simp
          finally have "(ε (F b) C F (D.inv (η (G (F b)))) C C.inv (ε (F (G (F b))))) C F (η b) = F b"
            by blast
          thus ?thesis
            using assms by simp
        qed
        show "C.ide (F (η b) C ?ε' (F b))"
        proof -
          have "(F (η b) C ?ε' (F b)) C F (η b) = F (G (F b)) C F (η b)"
          proof -
            have "(F (η b) C ?ε' (F b)) C F (η b) =
                  F (η b) C (ε (F b) C F (D.inv (η (G (F b)))) C C.inv (ε (F (G (F b))))) C F (η b)"
              using C.comp_assoc by simp
            also have "... = F (η b)"
              using assms 3
                    C.comp_arr_dom
                      [of "F (η b)" "(ε (F b) C F (D.inv (η (G (F b)))) C
                                       C.inv (ε (F (G (F b))))) C F (η b)"]
              by auto
            also have "... = F (G (F b)) C F (η b)"
              using assms C.comp_cod_arr by simp
            finally show ?thesis by blast
          qed
          hence "F (η b) C ?ε' (F b) = F (G (F b))"
            using assms C.iso_cancel_right by simp
          thus ?thesis
            using assms by simp
        qed
      qed
      show "C.inv (F (η b)) = ?ε' (F b)"
        using assms 2 C.inverse_unique by simp
      show "F (η b) = C.inv (?ε' (F b))"
      proof -
        have "C.inverse_arrows (?ε' (F b)) (F (η b))"
          using assms 2 by auto
        thus ?thesis
          using assms C.inverse_unique by simp
      qed
    qed

    interpretation FoGoF: composite_functor D C C F F o G ..
    interpretation GoFoG: composite_functor C D D G G o F ..

    interpretation natural_transformation D C F FoGoF.map F  η
    proof -
      have "F  D.map = F"
        using hcomp_ide_dom F.natural_transformation_axioms by blast
      moreover have "F o (G o F) = FoGoF.map"
        by auto
      ultimately show "natural_transformation D C F FoGoF.map (F  η)"
        using η.natural_transformation_axioms F.natural_transformation_axioms
              horizontal_composite [of D D D.map "G o F" η C F F F]
        by simp
    qed

    interpretation natural_transformation C D G GoFoG.map η  G
      using η.natural_transformation_axioms G.natural_transformation_axioms
            horizontal_composite [of C D G G G ]
      by fastforce

    interpretation natural_transformation D C FoGoF.map F ‹ε'.map  F
      using ε'.natural_transformation_axioms F.natural_transformation_axioms
            horizontal_composite [of D C F F F]
      by fastforce

    interpretation natural_transformation C D GoFoG.map G G  ε'.map›
    proof -
      have "G o C.map = G"
        using hcomp_ide_dom G.natural_transformation_axioms by blast
      moreover have "G o (F o G) = GoFoG.map"
        by auto
      ultimately show "natural_transformation C D GoFoG.map G (G  ε'.map)"
        using G.natural_transformation_axioms ε'.natural_transformation_axioms
              horizontal_composite [of C C "F o G" C.map ε'.map D G G G]
        by simp
    qed

    interpretation ε'F_Fη: vertical_composite D C F FoGoF.map F F  η ‹ε'.map  F ..
    interpretation Gε'_ηG: vertical_composite C D G GoFoG.map G η o G G o ε'.map› ..

    interpretation ηε': unit_counit_adjunction C D F G η ε'.map
    proof
      show 1: "ε'F_Fη.map = F"
      proof
        fix g
        show "ε'F_Fη.map g = F g"
        proof (cases "D.arr g")
          show "¬ D.arr g  ε'F_Fη.map g = F g"
            using ε'F_Fη.is_extensional F.is_extensional by simp
          assume g: "D.arr g"
          have "ε'F_Fη.map g = ε' (F (D.cod g)) C F (η g)"
            using g ε'F_Fη.map_def by simp
          also have "... = ε' (F (D.cod g)) C F (η (D.cod g) D g)"
            using g η.is_natural_2 by simp
          also have "... = (ε' (F (D.cod g)) C F (η (D.cod g))) C F g"
            using g C.comp_assoc by simp
          also have "... = F (D.cod g) C F g"
            using g Fη_inverse(3) [of "D.cod g"] by fastforce
          also have "... = F g"
            using g C.comp_cod_arr by simp
          finally show "ε'F_Fη.map g = F g" by blast
        qed
      qed
      show "Gε'_ηG.map = G"
      proof
        fix f
        show "Gε'_ηG.map f = G f"
        proof (cases "C.arr f")
          show "¬ C.arr f  Gε'_ηG.map f = G f"
            using Gε'_ηG.is_extensional G.is_extensional by simp
          assume f: "C.arr f"
          have "F (Gε'_ηG.map f) = F (G (ε' (C.cod f)) D η (G f))"
            using f Gε'_ηG.map_def D.comp_assoc by simp
          also have "... = F (G (ε' (C.cod f)) D η (G (C.cod f)) D G f)"
            using f η.is_natural_2 [of "G f"] by simp
          also have "... = F (G (ε' (C.cod f))) C F (η (G (C.cod f))) C F (G f)"
            using f by simp
          also have "... = (F (G (ε' (C.cod f))) C C.inv (ε' (F (G (C.cod f))))) C F (G f)"
            using f Fη_inverse(4) C.comp_assoc by simp
          also have "... = (C.inv (ε' (C.cod f)) C ε' (C.cod f)) C F (G f)"
            using f ε'.inv_naturality [of "ε' (C.cod f)"] by simp
          also have "... = F (G (C.cod f)) C F (G f)"
            using f C.comp_inv_arr' [of "ε' (C.cod f)"] ε'.components_are_iso by simp
          also have "... = F (G f)"
            using f C.comp_cod_arr by simp
          finally have "F (Gε'_ηG.map f) = F (G f)" by blast
          moreover have "D.par (Gε'_ηG.map f) (G f)"
            using f by simp
          ultimately show "Gε'_ηG.map f = G f"
            using f F_is_faithful
            by (simp add: faithful_functor_axioms_def faithful_functor_def)
        qed
      qed
    qed

    interpretation ηε': adjoint_equivalence C D F G η ε'.map ..

    lemma refines_to_adjoint_equivalence:
    shows "adjoint_equivalence C D F G η ε'.map"
      ..

  end

end

Theory CartesianCategory

(*  Title:       CartesianCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2020
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Cartesian Category"

text‹
  In this chapter, we explore the notion of a ``cartesian category'', which we define
  to be a category having binary products and a terminal object.
  We show that every cartesian category extends to an ``elementary cartesian category'',
  whose definition assumes that specific choices have been made for projections and
  terminal object.
  Conversely, the underlying category of an elementary cartesian category is a
  cartesian category.
  We also show that cartesian categories are the same thing as categories with
  finite products.
›

theory CartesianCategory
imports Limit SetCat
begin

  section "Category with Binary Products"

  subsection "Binary Product Diagrams"

  text ‹
    The ``shape'' of a binary product diagram is a category having two distinct identity arrows
    and no non-identity arrows.
  ›

  locale binary_product_shape
  begin

    sublocale concrete_category ‹UNIV :: bool set› λa b. if a = b then {()} else {}
                                λ_. () λ_ _ _ _ _. ()
      apply (unfold_locales, auto)
       apply (meson empty_iff)
      by (meson empty_iff)

    abbreviation comp
    where "comp  COMP"

    abbreviation FF
    where "FF  MkIde False"

    abbreviation TT
    where "TT  MkIde True"

    lemma arr_char:
    shows "arr f  f = FF  f = TT"
      using arr_char by (cases f, simp_all)

    lemma ide_char:
    shows "ide f  f = FF  f = TT"
      using ide_char ide_MkIde by (cases f, auto)

    lemma is_discrete:
    shows "ide f  arr f"
      using arr_char ide_char by simp

    lemma dom_simp [simp]:
    assumes "arr f"
    shows "dom f = f"
      using assms is_discrete by simp

    lemma cod_simp [simp]:
    assumes "arr f"
    shows "cod f = f"
      using assms is_discrete by simp

    lemma seq_char:
    shows "seq f g  arr f  f = g"
      by auto

    lemma comp_simp [simp]:
    assumes "seq f g"
    shows "comp f g = f"
      using assms seq_char by fastforce

  end

  locale binary_product_diagram =
    J: binary_product_shape +
    C: category C
  for C :: "'c comp"      (infixr "" 55)
  and a0 :: 'c
  and a1 :: 'c +
  assumes is_discrete: "C.ide a0  C.ide a1"
  begin

    notation J.comp      (infixr "J" 55)

    fun map
    where "map J.FF = a0"
        | "map J.TT = a1"
        | "map _ = C.null"

    sublocale diagram J.comp C map
    proof
      show "f. ¬ J.arr f  map f = C.null"
        using J.arr_char map.elims by auto
      fix f
      assume f: "J.arr f"
      show "C.arr (map f)"
        using f J.arr_char is_discrete C.ideD(1) map.simps(1-2) by metis
      show "C.dom (map f) = map (J.dom f)"
        using f J.arr_char J.dom_char is_discrete by force
      show "C.cod (map f) = map (J.cod f)"
        using f J.arr_char J.cod_char is_discrete by force
      next
      fix f g
      assume fg: "J.seq g f"
      show "map (g J f) = map g  map f"
        using fg J.arr_char J.seq_char J.null_char J.not_arr_null is_discrete
        by (metis (no_types, lifting) C.comp_ide_self J.comp_simp map.simps(1-2))
    qed

  end

  subsection "Category with Binary Products"

  text ‹
    A \emph{binary product} in a category @{term C} is a limit of a binary product diagram
    in @{term C}.
  ›

  context binary_product_diagram
  begin

    definition mkCone
    where "mkCone p0 p1  λj. if j = J.FF then p0 else if j = J.TT then p1 else C.null"

    abbreviation is_rendered_commutative_by
    where "is_rendered_commutative_by p0 p1 
           C.seq a0 p0  C.seq a1 p1  C.dom p0 = C.dom p1"

    abbreviation has_as_binary_product
    where "has_as_binary_product p0 p1  limit_cone (C.dom p0) (mkCone p0 p1)"

    lemma cone_mkCone:
    assumes "is_rendered_commutative_by p0 p1"
    shows "cone (C.dom p0) (mkCone p0 p1)"
    proof -
      interpret E: constant_functor J.comp C ‹C.dom p0
        using assms by unfold_locales auto
      show "cone (C.dom p0) (mkCone p0 p1)"
        using assms mkCone_def J.arr_char E.map_simp is_discrete C.comp_ide_arr C.comp_arr_dom
        by unfold_locales auto
    qed

    lemma is_rendered_commutative_by_cone:
    assumes "cone a χ"
    shows "is_rendered_commutative_by (χ J.FF) (χ J.TT)"
    proof -
      interpret χ: cone J.comp C map a χ
        using assms by auto
      show ?thesis
        using is_discrete by simp
    qed

    lemma mkCone_cone:
    assumes "cone a χ"
    shows "mkCone (χ J.FF) (χ J.TT) = χ"
    proof -
      interpret χ: cone J.comp C map a χ
        using assms by auto
      interpret mkCone_χ: cone J.comp C map ‹C.dom (χ J.FF) ‹mkCone (χ J.FF) (χ J.TT)
        using assms is_rendered_commutative_by_cone cone_mkCone by blast
      show ?thesis
        using mkCone_def χ.is_extensional J.ide_char mkCone_def
              NaturalTransformation.eqI [of J.comp C]
              χ.natural_transformation_axioms mkCone_χ.natural_transformation_axioms
        by fastforce
    qed

  end

  locale binary_product_cone =
    J: binary_product_shape +
    C: category C +
    D: binary_product_diagram C f0 f1 +
    limit_cone J.comp C D.map ‹C.dom p0 ‹D.mkCone p0 p1
  for C :: "'c comp"      (infixr "" 55)
  and f0 :: 'c
  and f1 :: 'c
  and p0 :: 'c
  and p1 :: 'c
  begin

    lemma renders_commutative:
    shows "D.is_rendered_commutative_by p0 p1"
      using cone_axioms D.is_rendered_commutative_by_cone D.mkCone_def Φ.Ya.Cop_S.arr.simps(1)
      by (metis (no_types, lifting))  (* TODO: pretty opaque *)

    lemma is_universal':
    assumes "D.is_rendered_commutative_by p0' p1'"
    shows "∃!h. «h : C.dom p0'  C.dom p0»  p0  h = p0'  p1  h = p1'"
    proof -
      have "D.cone (C.dom p0') (D.mkCone p0' p1')"
        using assms D.cone_mkCone by blast
      hence "∃!h. «h : C.dom p0'  C.dom p0» 
                  D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
        using is_universal by simp
      moreover have "h. «h : C.dom p0'  C.dom p0» 
                           D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' 
                           p0  h = p0'  p1  h = p1'"
      proof -
        fix h
        assume h: "«h : C.dom p0'  C.dom p0»"
        show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' 
              p0  h = p0'  p1  h = p1'"
        proof
          assume 1: "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
          show "p0  h = p0'  p1  h = p1'"
          proof
            show "p0  h = p0'"
            proof -
              have "p0' = D.mkCone p0' p1' J.FF"
                using D.mkCone_def J.arr_char by simp
              also have "... = D.cones_map h (D.mkCone p0 p1) J.FF"
                using 1 by simp
              also have "... = p0  h"
                using h D.mkCone_def J.arr_char cone_χ by auto
              finally show ?thesis by auto
            qed
            show "p1  h = p1'"
            proof -
              have "p1' = D.mkCone p0' p1' J.TT"
                using D.mkCone_def J.arr_char by simp
              also have "... = D.cones_map h (D.mkCone p0 p1) J.TT"
                using 1 by simp
              also have "... = p1  h"
                using h D.mkCone_def J.arr_char cone_χ by auto
              finally show ?thesis by auto
            qed
          qed
          next
          assume 1: "p0  h = p0'  p1  h = p1'"
          show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
            using h 1 cone_χ D.mkCone_def by auto
        qed
      qed
      ultimately show ?thesis by blast
    qed

    lemma induced_arrowI':
    assumes "D.is_rendered_commutative_by p0' p1'"
    shows "«induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0'  C.dom p0»"
    and "p0  induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
    and "p1  induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
    proof -
      interpret A': constant_functor J.comp C ‹C.dom p0'
        using assms by (unfold_locales, auto)
      have cone: "D.cone (C.dom p0') (D.mkCone p0' p1')"
        using assms D.cone_mkCone [of p0' p1'] by blast
      show 0: "p0  induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
      proof -
        have "p0  induced_arrow (C.dom p0') (D.mkCone p0' p1') =
                D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                            (D.mkCone p0 p1) J.FF"
          using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by force
        also have "... = p0'"
        proof -
          have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                            (D.mkCone p0 p1) =
                D.mkCone p0' p1'"
            using cone induced_arrowI by blast
          thus ?thesis
            using J.arr_char D.mkCone_def by simp
        qed
        finally show ?thesis by auto
      qed
      show "p1  induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
      proof -
        have "p1  induced_arrow (C.dom p1') (D.mkCone p0' p1') =
                D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                            (D.mkCone p0 p1) J.TT"
          using assms cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by fastforce
        also have "... = p1'"
        proof -
          have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                            (D.mkCone p0 p1) =
                D.mkCone p0' p1'"
            using cone induced_arrowI by blast
          thus ?thesis
            using J.arr_char D.mkCone_def by simp
        qed
        finally show ?thesis by auto
      qed
      show "«induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0'  C.dom p0»"
        using 0 cone induced_arrowI by simp
    qed

  end

  context category
  begin

    definition has_as_binary_product
    where "has_as_binary_product a0 a1 p0 p1 
           ide a0  ide a1  binary_product_diagram.has_as_binary_product C a0 a1 p0 p1"

    definition has_binary_products
    where "has_binary_products =
           (a0 a1. ide a0  ide a1  (p0 p1. has_as_binary_product a0 a1 p0 p1))"

  end

  locale category_with_binary_products =
    category +
  assumes has_binary_products: has_binary_products

  subsection "Elementary Category with Binary Products"

  text ‹
    An \emph{elementary category with binary products} is a category equipped with a specific
    way of mapping each pair of objects a› and b› to a pair of arrows 𝔭1[a, b]› and 𝔭0[a, b]›
    that comprise a universal span.  It is useful to assume that the mappings that produce
    𝔭1[a, b]› and 𝔭0[a, b]› from a› and b› are extensional; that is, if either a› or b›
    is not an identity, then 𝔭1[a, b]› and 𝔭0[a, b]› are null›.
  ›

  locale elementary_category_with_binary_products =
    category C
  for C :: "'a comp"                             (infixr "" 55)
  and pr0 :: "'a  'a  'a"                    ("𝔭0[_, _]")
  and pr1 :: "'a  'a  'a"                    ("𝔭1[_, _]") +
  assumes pr0_ext: "¬ (ide a  ide b)  𝔭0[a, b] = null"
  and pr1_ext: "¬ (ide a  ide b)  𝔭1[a, b] = null"
  and span_pr: " ide a; ide b   span 𝔭1[a, b] 𝔭0[a, b]"
  and cod_pr0: " ide a; ide b   cod 𝔭0[a, b] = b"
  and cod_pr1: " ide a; ide b   cod 𝔭1[a, b] = a"
  and universal: "span f g  ∃!l. 𝔭1[cod f, cod g]  l = f  𝔭0[cod f, cod g]  l = g"
  begin

    lemma pr0_in_hom':
    assumes "ide a" and "ide b"
    shows "«𝔭0[a, b] : dom 𝔭0[a, b]  b»"
      using assms span_pr cod_pr0 by auto

    lemma pr1_in_hom':
    assumes "ide a" and "ide b"
    shows "«𝔭1[a, b] : dom 𝔭0[a, b]  a»"
      using assms span_pr cod_pr1 by auto

    text ‹
      We introduce a notation for tupling, which denotes the arrow into a product that
      is induced by a span.
    ›

    definition tuple         ("_, _")
    where "f, g  if span f g then
                      THE l. 𝔭1[cod f, cod g]  l = f  𝔭0[cod f, cod g]  l = g
                    else null"

    text ‹
      The following defines product of arrows (not just of objects).  It will take a little
      while before we can prove that it is functorial, but for right now it is nice to have
      it as a notation for the apex of a product cone.  We have to go through some slightly
      unnatural contortions in the development here, though, to avoid having to introduce a
      separate preliminary notation just for the product of objects.
    ›
    (* TODO: I want to use × but it has already been commandeered for product types. *)
    definition prod         (infixr "" 51)
    where "f  g  f  𝔭1[dom f, dom g], g  𝔭0[dom f, dom g]"

    lemma seq_pr_tuple:
    assumes "span f g"
    shows "seq 𝔭0[cod f, cod g] f, g"
    proof -
      have "𝔭0[cod f, cod g]  f, g = g"
        unfolding tuple_def
        using assms universal theI [of "λl. 𝔭1[cod f, cod g]  l = f  𝔭0[cod f, cod g]  l = g"]
        by simp meson
      thus ?thesis
        using assms by simp
    qed

    lemma tuple_pr_arr:
    assumes "ide a" and "ide b" and "seq 𝔭0[a, b] h"
    shows "𝔭1[a, b]  h, 𝔭0[a, b]  h = h"
      unfolding tuple_def
      using assms span_pr cod_pr0 cod_pr1 universal [of "𝔭1[a, b]  h" "𝔭0[a, b]  h"]
            theI_unique [of "λl. 𝔭1[a, b]  l = 𝔭1[a, b]  h  𝔭0[a, b]  l = 𝔭0[a, b]  h" h]
      by auto

    lemma pr_tuple [simp]:
    assumes "span f g" and "cod f = a" and "cod g = b"
    shows "𝔭1[a, b]  f, g = f" and "𝔭0[a, b]  f, g = g"
    proof -
      have 1: "𝔭1[a, b]  f, g = f  𝔭0[a, b]  f, g = g"
        unfolding tuple_def
        using assms universal theI [of "λl. 𝔭1[a, b]  l = f  𝔭0[a, b]  l = g"]
        by simp meson
      show "𝔭1[a, b]  f, g = f" using 1 by simp
      show "𝔭0[a, b]  f, g = g" using 1 by simp
    qed

    lemma cod_tuple:
    assumes "span f g"
    shows "cod f, g = cod f  cod g"
    proof -
      have "cod f  cod g = 𝔭1[cod f, cod g], 𝔭0[cod f, cod g]"
        unfolding prod_def
        using assms comp_cod_arr span_pr cod_pr0 cod_pr1 by simp
      also have "... = 𝔭1[cod f, cod g]  dom 𝔭0[cod f, cod g],
                        𝔭0[cod f, cod g]  dom 𝔭0[cod f, cod g]"
        using assms span_pr comp_arr_dom by simp
      also have "... = dom 𝔭0[cod f, cod g]"
        using assms tuple_pr_arr span_pr by simp
      also have "... = cod f, g"
        using assms seq_pr_tuple by blast
      finally show ?thesis by simp
    qed

    lemma tuple_in_hom [intro]:
    assumes "«f : a  b»" and "«g : a  c»"
    shows "«f, g : a  b  c»"
      using assms pr_tuple dom_comp cod_tuple
      apply (elim in_homE, intro in_homI)
        apply (metis seqE)
      by metis+

    lemma tuple_in_hom' [simp]:
    assumes "arr f" and "dom f = a" and "cod f = b"
    and "arr g" and "dom g = a" and "cod g = c"
    shows "«f, g : a  b  c»"
      using assms by auto

    lemma tuple_ext:
    assumes "¬ span f g"
    shows "f, g = null"
      unfolding tuple_def
      by (simp add: assms)

    lemma tuple_simps [simp]:
    assumes "span f g"
    shows "arr f, g" and "dom f, g = dom f" and "cod f, g = cod f  cod g"
    proof -
      show "arr f, g"
        using assms tuple_in_hom by blast
      show "dom f, g = dom f"
        using assms tuple_in_hom
        by (metis dom_comp pr_tuple(1))
      show "cod f, g = cod f  cod g"
        using assms cod_tuple by auto
    qed

    lemma tuple_pr [simp]:
    assumes "ide a" and "ide b"
    shows "𝔭1[a, b], 𝔭0[a, b] = a  b"
    proof -
      have 1: "dom 𝔭0[a, b] = a  b"
        using assms seq_pr_tuple cod_tuple [of "𝔭1[a, b]" "𝔭0[a, b]"] span_pr
              pr0_in_hom' pr1_in_hom'
        by (metis cod_pr0 cod_pr1 seqE)
      hence "𝔭1[a, b], 𝔭0[a, b] = 𝔭1[a, b]  (a  b), 𝔭0[a, b]  (a  b)"
        using assms pr0_in_hom' pr1_in_hom' comp_arr_dom span_pr by simp
      thus ?thesis
        using assms 1 tuple_pr_arr span_pr
        by (metis comp_arr_dom)
    qed

    lemma pr_in_hom [intro, simp]:
    assumes "ide a" and "ide b"
    shows "«𝔭0[a, b] : a  b  b»" and "«𝔭1[a, b] : a  b  a»"
    proof -
      show 0: "«𝔭0[a, b] : a  b  b»"
        using assms pr0_in_hom' seq_pr_tuple [of "𝔭1[a, b]" "𝔭0[a, b]"]
              cod_tuple [of "𝔭1[a, b]" "𝔭0[a, b]"] span_pr cod_pr0 cod_pr1
        by (intro in_homI, auto)
      show "«𝔭1[a, b] : a  b  a»"
        using assms 0 span_pr pr1_in_hom' by fastforce
    qed

    lemma pr_simps [simp]:
    assumes "ide a" and "ide b"
    shows "arr 𝔭0[a, b]" and "dom 𝔭0[a, b] = a  b" and "cod 𝔭0[a, b] = b"
    and "arr 𝔭1[a, b]" and "dom 𝔭1[a, b] = a  b" and "cod 𝔭1[a, b] = a"
      using assms pr_in_hom by blast+

    lemma arr_pr0_iff [iff]:
    shows "arr 𝔭0[a, b]  ide a  ide b"
    proof
      show "ide a  ide b  arr 𝔭0[a, b]"
        using pr_in_hom by auto
      show "arr 𝔭0[a, b]  ide a  ide b"
        using pr0_ext not_arr_null by metis
    qed

    lemma arr_pr1_iff [iff]:
    shows "arr 𝔭1[a, b]  ide a  ide b"
    proof
      show "ide a  ide b  arr 𝔭1[a, b]"
        using pr_in_hom by auto
      show "arr 𝔭1[a, b]  ide a  ide b"
        using pr1_ext not_arr_null by metis
    qed

    lemma pr_joint_monic:
    assumes "seq 𝔭0[a, b] h"
    and "𝔭0[a, b]  h = 𝔭0[a, b]  h'" and "𝔭1[a, b]  h = 𝔭1[a, b]  h'"
    shows "h = h'"
      using assms
      by (metis arr_pr0_iff seqE tuple_pr_arr)

    lemma comp_tuple_arr [simp]:
    assumes "span f g" and "arr h" and "dom f = cod h"
    shows "f, g  h = f  h, g  h"
    proof (intro pr_joint_monic [where h = "f, g  h"])
      show "seq 𝔭0[cod f, cod g] (f, g  h)"
        using assms by fastforce
      show "𝔭0[cod f, cod g]  f, g  h = 𝔭0[cod f, cod g]  f  h, g  h"
      proof -
        have "𝔭0[cod f, cod g]  f, g  h = (𝔭0[cod f, cod g]  f, g)  h"
          using comp_assoc by simp
        thus ?thesis
          using assms by simp
      qed
      show "𝔭1[cod f, cod g]  f, g  h = 𝔭1[cod f, cod g]  f  h, g  h"
      proof -
        have "𝔭1[cod f, cod g]  f, g  h = (𝔭1[cod f, cod g]  f, g)  h"
          using comp_assoc by simp
        thus ?thesis
          using assms by simp
      qed
    qed

    lemma ide_prod [intro, simp]:
    assumes "ide a" and "ide b"
    shows "ide (a  b)"
      using assms pr_simps ide_dom [of "𝔭0[a, b]"] by simp

    lemma prod_in_hom [intro]:
    assumes "«f : a  c»" and "«g : b  d»"
    shows "«f  g : a  b  c  d»"
      using assms prod_def by fastforce

    lemma prod_in_hom' [simp]:
    assumes "arr f" and "dom f = a" and "cod f = c"
    and "arr g" and "dom g = b" and "cod g = d"
    shows "«f  g : a  b  c  d»"
      using assms by blast

    lemma prod_simps [simp]:
    assumes "arr f0" and "arr f1"
    shows "arr (f0  f1)"
    and "dom (f0  f1) = dom f0  dom f1"
    and "cod (f0  f1) = cod f0  cod f1"
      using assms prod_in_hom by blast+

  end

  subsection "Agreement between the Definitions"

  text ‹
    We now show that a category with binary products extends (by making a choice)
    to an elementary category with binary products, and that the underlying category
    of an elementary category with binary products is a category with binary products.
  ›

  context category_with_binary_products
  begin

    definition pr1
    where "pr1 a b  if ide a  ide b then
                        fst (SOME x. has_as_binary_product a b (fst x) (snd x))
                      else null"

    definition pr0
    where "pr0 a b  if ide a  ide b then
                        snd (SOME x. has_as_binary_product a b (fst x) (snd x))
                      else null"

    lemma pr_yields_binary_product:
    assumes "ide a" and "ide b"
    shows "has_as_binary_product a b (pr1 a b) (pr0 a b)"
    proof -
      have "x. has_as_binary_product a b (fst x) (snd x)"
        using assms has_binary_products has_binary_products_def has_as_binary_product_def
        by simp
      thus ?thesis
        using assms has_binary_products has_binary_products_def pr0_def pr1_def
              someI_ex [of "λx. has_as_binary_product a b (fst x) (snd x)"]
        by simp
    qed

    interpretation elementary_category_with_binary_products C pr0 pr1
    proof
      show "a b. ¬ (ide a  ide b)  pr0 a b = null"
        using pr0_def by auto
      show "a b. ¬ (ide a  ide b)  pr1 a b = null"
        using pr1_def by auto
      fix a b
      assume a: "ide a" and b: "ide b"
      interpret J: binary_product_shape .
      interpret D: binary_product_diagram C a b
        using a b by unfold_locales auto
      let  = "D.mkCone (pr1 a b) (pr0 a b)"
      interpret χ: limit_cone J.comp C D.map ‹dom (pr1 a b) 
        using a b pr_yields_binary_product
        by (simp add: has_as_binary_product_def)
      have 1: "pr1 a b =  J.FF  pr0 a b =  J.TT"
        using D.mkCone_def by simp
      show "span (pr1 a b) (pr0 a b)"
        using 1 χ.preserves_reflects_arr J.seqE J.arr_char J.seq_char J.is_category
              D.is_rendered_commutative_by_cone χ.cone_axioms
        by metis
      show "cod (pr1 a b) = a"
        using 1 χ.preserves_cod [of J.FF] J.cod_char J.arr_char by auto
      show "cod (pr0 a b) = b"
        using 1 χ.preserves_cod [of J.TT] J.cod_char J.arr_char by auto
      next
      fix f g
      assume fg: "span f g"
      show "∃!l. pr1 (cod f) (cod g)  l = f  pr0 (cod f) (cod g)  l = g"
      proof -
        interpret J: binary_product_shape .
        interpret D: binary_product_diagram C ‹cod f ‹cod g
          using fg by unfold_locales auto
        let  = "D.mkCone (pr1 (cod f) (cod g)) (pr0 (cod f) (cod g))"
        interpret χ: limit_cone J.comp C D.map ‹dom (pr1 (cod f) (cod g)) 
          using fg pr_yields_binary_product [of "cod f" "cod g"] has_as_binary_product_def
          by simp
        interpret χ: binary_product_cone C ‹cod f ‹cod g
                       ‹pr1 (cod f) (cod g) ‹pr0 (cod f) (cod g) ..
        have 1: "pr1 (cod f) (cod g) =  J.FF  pr0 (cod f) (cod g) =  J.TT"
          using D.mkCone_def by simp
        show "∃!l. pr1 (cod f) (cod g)  l = f  pr0 (cod f) (cod g)  l = g"
        proof -
          have "∃!l. «l : dom f  dom (pr1 (cod f) (cod g))» 
                     pr1 (cod f) (cod g)  l = f  pr0 (cod f) (cod g)  l = g"
            using fg χ.is_universal' by simp
          moreover have "l. pr1 (cod f) (cod g)  l = f
                                 «l : dom f  dom (pr1 (cod f) (cod g))»"
            using fg dom_comp in_homI seqE seqI by metis
          ultimately show ?thesis by auto
        qed
      qed
    qed

    proposition extends_to_elementary_category_with_binary_products:
    shows "elementary_category_with_binary_products C pr0 pr1"
      ..

  end

  context elementary_category_with_binary_products
  begin

    interpretation category_with_binary_products C
    proof
      show "has_binary_products"
      proof (unfold has_binary_products_def)
        have "a b. ide a  ide b  p0 p1. has_as_binary_product a b p0 p1"
        proof -
          fix a b
          assume ab: "ide a  ide b"
          interpret J: binary_product_shape .
          interpret D: binary_product_diagram C a b
            using ab by unfold_locales auto
          have 2: "D.is_rendered_commutative_by 𝔭1[a, b] 𝔭0[a, b]"
            using ab by simp
          let  = "D.mkCone 𝔭1[a, b] 𝔭0[a, b]"
          interpret χ: cone J.comp C D.map ‹dom 𝔭1[a, b] 
            using D.cone_mkCone 2 by auto
          interpret χ: limit_cone J.comp C D.map ‹dom 𝔭1[a, b] 
          proof
            fix a' χ'
            assume χ': "D.cone a' χ'"
            interpret χ': cone J.comp C D.map a' χ'
              using χ' by simp
            show "∃!h. «h : a'  dom 𝔭1[a, b]» 
                       D.cones_map h (D.mkCone 𝔭1[a, b] 𝔭0[a, b]) = χ'"
            proof
              let ?h = "χ' J.FF, χ' J.TT"
              show h': "«?h : a'  dom 𝔭1[a, b]» 
                        D.cones_map ?h (D.mkCone 𝔭1[a, b] 𝔭0[a, b]) = χ'"
              proof
                show h: "«?h : a'  dom 𝔭1[a, b]»"
                  using ab tuple_in_hom J.ide_char by fastforce
                show "D.cones_map ?h (D.mkCone 𝔭1[a, b] 𝔭0[a, b]) = χ'"
                proof -
                  interpret χ'h: cone J.comp C D.map a'
                                   ‹D.cones_map ?h (D.mkCone 𝔭1[a, b] 𝔭0[a, b])
                  proof -
                    have "D.mkCone 𝔭1[a, b] 𝔭0[a, b]  D.cones (cod χ' J.FF, χ' J.TT)"
                      using ab h D.cone_mkCone D.is_rendered_commutative_by_cone
                            χ.cone_axioms
                      by auto
                    hence "D.cones_map ?h (D.mkCone 𝔭1[a, b] 𝔭0[a, b])  D.cones a'"
                      using ab h D.cones_map_mapsto by blast
                    thus "D.cone a' (D.cones_map ?h (D.mkCone 𝔭1[a, b] 𝔭0[a, b]))"
                      by simp
                  qed
                  show ?thesis
                  proof -
                    have "j. J.ide j  D.cones_map ?h (D.mkCone 𝔭1[a, b] 𝔭0[a, b]) j = χ' j"
                      using ab h J.ide_char D.mkCone_def χ.cone_axioms by auto
                    thus ?thesis
                      using NaturalTransformation.eqI
                            χ'.natural_transformation_axioms χ'h.natural_transformation_axioms
                      by blast
                  qed
                qed
              qed
              show "h. «h : a'  dom 𝔭1[a, b]» 
                        D.cones_map h (D.mkCone 𝔭1[a, b] 𝔭0[a, b]) = χ'  h = ?h"
              proof -
                fix h
                assume 1: "«h : a'  dom 𝔭1[a, b]» 
                           D.cones_map h (D.mkCone 𝔭1[a, b] 𝔭0[a, b]) = χ'"
                hence "cod h = dom 𝔭1[a, b]" by auto
                show "h = ?h"
                  using 1 ab χ.cone_axioms D.mkCone_def h' pr_joint_monic [of a b h ?h]
                  by auto
              qed
            qed
          qed
          have "has_as_binary_product a b 𝔭1[a, b] 𝔭0[a, b]"
            using ab has_as_binary_product_def χ.limit_cone_axioms by blast
          thus "p0 p1. has_as_binary_product a b p0 p1"
            by blast
        qed
        thus "a b. ide a  ide b  (p0 p1. has_as_binary_product a b p0 p1)"
          by simp
      qed
    qed

    proposition is_category_with_binary_products:
    shows "category_with_binary_products C"
      ..

  end

  subsection "Further Properties"

  context elementary_category_with_binary_products
  begin

    lemma interchange:
    assumes "seq h f" and "seq k g"
    shows "(h  k)  (f  g) = h  f  k  g"
      using assms prod_def comp_tuple_arr comp_assoc by fastforce

    lemma pr_naturality [simp]:
    assumes "arr g" and "dom g = b" and "cod g = d"
        and "arr f" and "dom f = a" and "cod f = c"
    shows "𝔭0[c, d]  (f  g) = g  𝔭0[a, b]"
    and "𝔭1[c, d]  (f  g) = f  𝔭1[a, b]"
      using assms prod_def by fastforce+

    abbreviation dup ("𝖽[_]")
    where "𝖽[f]  f, f"

    lemma dup_in_hom [intro, simp]:
    assumes "«f : a  b»"
    shows "«𝖽[f] : a  b  b»"
      using assms by fastforce

    lemma dup_simps [simp]:
    assumes "arr f"
    shows "arr 𝖽[f]" and "dom 𝖽[f] = dom f" and "cod 𝖽[f] = cod f  cod f"
      using assms dup_in_hom by auto

    lemma dup_naturality:
    assumes "«f : a  b»"
    shows "𝖽[b]  f = (f  f)  𝖽[a]"
      using assms prod_def comp_arr_dom comp_cod_arr comp_tuple_arr comp_assoc
      by fastforce

    lemma pr_dup [simp]:
    assumes "ide a"
    shows "𝔭0[a, a]  𝖽[a] = a" and "𝔭1[a, a]  𝖽[a] = a"
      using assms by simp_all

    lemma prod_tuple:
    assumes "span f g" and "seq h f" and "seq k g"
    shows "(h  k)  f, g = h  f, k  g"
      using assms prod_def comp_assoc comp_tuple_arr by fastforce

    lemma tuple_eqI:
    assumes "seq 𝔭0[b, c] f" and "seq 𝔭1[b, c] f"
    and "𝔭0[b, c]  f = f0" and "𝔭1[b, c]  f = f1"
    shows "f = f1, f0"
      using assms pr_joint_monic [of b c "f1, f0" f] pr_tuple by auto

    definition assoc ("𝖺[_, _, _]")
    where "𝖺[a, b, c]  𝔭1[a, b]  𝔭1[a  b, c], 𝔭0[a, b]  𝔭1[a  b, c], 𝔭0[a  b, c]"

    definition assoc' ("𝖺-1[_, _, _]")
    where "𝖺-1[a, b, c]  𝔭1[a, b  c], 𝔭1[b, c]  𝔭0[a, b  c], 𝔭0[b, c]  𝔭0[a, b  c]"

    lemma assoc_in_hom [intro]:
    assumes "ide a" and "ide b" and "ide c"
    shows "«𝖺[a, b, c] : (a  b)  c  a  (b  c)»"
      using assms assoc_def by auto

    lemma assoc_simps [simp]:
    assumes "ide a" and "ide b" and "ide c"
    shows "arr 𝖺[a, b, c]"
    and "dom 𝖺[a, b, c] = (a  b)  c"
    and "cod 𝖺[a, b, c] = a  (b  c)"
      using assms assoc_in_hom by auto

    lemma assoc'_in_hom [intro]:
    assumes "ide a" and "ide b" and "ide c"
    shows "«𝖺-1[a, b, c] : a  (b  c)  (a  b)  c»"
      using assms assoc'_def by auto

    lemma assoc'_simps [simp]:
    assumes "ide a" and "ide b" and "ide c"
    shows "arr 𝖺-1[a, b, c]"
    and "dom 𝖺-1[a, b, c] = a  (b  c)"
    and "cod 𝖺-1[a, b, c] = (a  b)  c"
      using assms assoc'_in_hom by auto

    lemma assoc_naturality:
    assumes "«f0 : a0  b0»" and "«f1 : a1  b1»" and "«f2 : a2  b2»"
    shows "𝖺[b0, b1, b2]  ((f0  f1)  f2) = (f0  (f1  f2))  𝖺[a0, a1, a2]"
    proof -
      have "𝔭0[b0, b1  b2]  𝖺[b0, b1, b2]  ((f0  f1)  f2) =
            𝔭0[b0, b1  b2]  (f0  (f1  f2))  𝖺[a0, a1, a2]"
      proof -
        have "𝔭0[b0, b1  b2]  𝖺[b0, b1, b2]  ((f0  f1)  f2) =
              (𝔭0[b0, b1  b2]  𝖺[b0, b1, b2])  ((f0  f1)  f2)"
          using comp_assoc by simp
        also have "... = 𝔭0[b0, b1]  𝔭1[b0  b1, b2], 𝔭0[b0  b1, b2]  ((f0  f1)  f2)"
          using assms assoc_def by fastforce
        also have "... = (𝔭0[b0, b1]  𝔭1[b0  b1, b2])  ((f0  f1)  f2),
                          𝔭0[b0  b1, b2]  ((f0  f1)  f2)"
          using assms comp_tuple_arr by fastforce
        also have "... = (𝔭0[b0, b1]  (f0  f1))  𝔭1[a0  a1, a2], f2  𝔭0[a0  a1, a2]"
          using assms comp_assoc by fastforce
        also have "... = f1  𝔭0[a0, a1]  𝔭1[a0  a1, a2], f2  𝔭0[a0  a1, a2]"
          using assms comp_assoc
          by (metis in_homE pr_naturality(1))
        also have "... = 𝔭0[b0, b1  b2]  (f0  (f1  f2))  𝖺[a0, a1, a2]"
          using assms comp_assoc assoc_def prod_tuple by fastforce
        finally show ?thesis by blast
      qed
      moreover have "𝔭1[b0, b1  b2]  𝖺[b0, b1, b2]  ((f0  f1)  f2) =
                     𝔭1[b0, b1  b2]  (f0  (f1  f2))  𝖺[a0, a1, a2]"
      proof -
        have "𝔭1[b0, b1  b2]  𝖺[b0, b1, b2]  ((f0  f1)  f2) =
              (𝔭1[b0, b1  b2]  𝖺[b0, b1, b2])  ((f0  f1)  f2)"
          using comp_assoc by simp
        also have "... = (𝔭1[b0, b1]  𝔭1[b0  b1, b2])  ((f0  f1)  f2)"
          using assms assoc_def by fastforce
        also have "... = (𝔭1[b0, b1]  (f0  f1))  𝔭1[a0  a1, a2]"
          using assms comp_assoc by fastforce
        also have "... = f0  𝔭1[a0, a1]  𝔭1[a0  a1, a2]"
          using assms comp_assoc
          by (metis in_homE pr_naturality(2))
        also have "... = 𝔭1[b0, b1  b2]  (f0  (f1  f2))  𝖺[a0, a1, a2]"
        proof -
          have "𝔭1[b0, b1  b2]  (f0  (f1  f2))  𝖺[a0, a1, a2] =
                (𝔭1[b0, b1  b2]  (f0  (f1  f2)))  𝖺[a0, a1, a2]"
            using comp_assoc by simp
          also have "... = f0  𝔭1[a0, a1  a2]  𝖺[a0, a1, a2]"
            using assms comp_assoc by fastforce
          also have "... = f0  𝔭1[a0, a1]  𝔭1[a0  a1, a2]"
            using assms assoc_def by fastforce
          finally show ?thesis by simp
        qed
        finally show ?thesis by blast
      qed
      ultimately show ?thesis
        using assms pr_joint_monic [of b0 "b1  b2" "𝖺[b0, b1, b2]  ((f0  f1)  f2)"
                                       "(f0  (f1  f2))  𝖺[a0, a1, a2]"]
        by fastforce
    qed

    lemma pentagon:
    assumes "ide a" and "ide b" and "ide c" and "ide d"
    shows "((a  𝖺[b, c, d])  𝖺[a, b  c, d])  (𝖺[a, b, c]  d) = 𝖺[a, b, c  d]  𝖺[a  b, c, d]"
    proof (intro pr_joint_monic
                   [where h = "((a  𝖺[b, c, d])  𝖺[a, b  c, d])  (𝖺[a, b, c]  d)"
                      and h' = "𝖺[a, b, c  d]  𝖺[a  b, c, d]"])
      show "seq 𝔭0[a, b  (c  d)] (((a  𝖺[b, c, d])  𝖺[a, b  c, d])  (𝖺[a, b, c]  d))"
        using assms by simp
      show "𝔭1[a, b  c  d]  ((a  𝖺[b, c, d])  𝖺[a, b  c, d])  (𝖺[a, b, c]  d) =
            𝔭1[a, b  c  d]  𝖺[a, b, c  d]  𝖺[a  b, c, d]"
      proof -
        have "𝔭1[a, b  c  d]  ((a  𝖺[b, c, d])  𝖺[a, b  c, d])  (𝖺[a, b, c]  d) =
              ((𝔭1[a, b  c  d]  (a  𝖺[b, c, d]))  𝖺[a, b  c, d])  (𝖺[a, b, c]  d)"
          using comp_assoc by simp
        also have "... = (𝔭1[a, (b  c)  d]  𝖺[a, b  c, d])  (𝖺[a, b, c]  d)"
          using assms pr_naturality(2) comp_cod_arr by force
        also have "... = 𝔭1[a, b  c]  𝔭1[a  b  c, d]  (𝖺[a, b, c]  d)"
          using assms assoc_def comp_assoc by simp
        also have "... = (𝔭1[a, b  c]  𝖺[a, b, c])  𝔭1[(a  b)  c, d]"
          using assms pr_naturality(2) comp_assoc by fastforce
        also have "... = 𝔭1[a, b]  𝔭1[a  b, c]  𝔭1[(a  b)  c, d]"
          using assms assoc_def comp_assoc by simp
        finally have "𝔭1[a, b  c  d]  ((a  𝖺[b, c, d])  𝖺[a, b  c, d])  (𝖺[a, b, c]  d) =
                      𝔭1[a, b]  𝔭1[a  b, c]  𝔭1[(a  b)  c, d]"
          by blast
        also have "... = 𝔭1[a, b  c  d]  𝖺[a, b, c  d]  𝖺[a  b, c, d]"
          using assms assoc_def comp_assoc by auto
        finally show ?thesis by blast
      qed
      show "𝔭0[a, b  (c  d)]  ((a  𝖺[b, c, d])  𝖺[a, b  c, d])  (𝖺[a, b, c]  d) =
            𝔭0[a, b  (c  d)]  𝖺[a, b, c  d]  𝖺[a  b, c, d]"
      proof -
        have "𝔭0[a, b  (c  d)]  ((a  𝖺[b, c, d])  𝖺[a, b  c, d])  (𝖺[a, b, c]  d) =
              𝔭0[a, b  c  d] 
                ((a  𝔭1[b, c]  𝔭1[b  c, d], 𝔭0[b, c]  𝔭1[b  c, d], 𝔭0[b  c, d]) 
                 𝔭1[a, b  c]  𝔭1[a  b  c, d],
                  𝔭0[a, b  c]  𝔭1[a  b  c, d], 𝔭0[a  b  c, d]) 
                (𝔭1[a, b]  𝔭1[a  b, c], 𝔭0[a, b]  𝔭1[a  b, c], 𝔭0[a  b, c]  d)"
          using assms assoc_def by simp
        also have "... = 𝔭1[b, c]  𝔭1[b  c, d],
                          𝔭0[b, c]  𝔭1[b  c, d], 𝔭0[b  c, d]  (𝔭0[a, (b  c)  d] 
                            𝔭1[a, b  c]  𝔭1[a  b  c, d],
                             𝔭0[a, b  c]  𝔭1[a  b  c, d], 𝔭0[a  b  c, d]) 
                            (𝔭1[a, b]  𝔭1[a  b, c],
                              𝔭0[a, b]  𝔭1[a  b, c], 𝔭0[a  b, c]  d)"
        proof -
          have "𝔭0[a, b  c  d] 
                  (a  𝔭1[b, c]  𝔭1[b  c, d], 𝔭0[b, c]  𝔭1[b  c, d], 𝔭0[b  c, d]) =
                𝔭1[b, c]  𝔭1[b  c, d], 𝔭0[b, c]  𝔭1[b  c, d], 𝔭0[b  c, d] 
                  𝔭0[a, (b  c)  d]"
            using assms assoc_def ide_in_hom pr_naturality(1) by auto
          thus ?thesis using comp_assoc by metis
        qed
        also have "... = 𝔭0[a, b]  𝔭1[a  b, c]  𝔭1[(a  b)  c, d],
                          𝔭0[a  b, c]  𝔭1[(a  b)  c, d], d  𝔭0[(a  b)  c, d]"
          using assms comp_assoc by simp
        also have "... = 𝔭0[a, b]  𝔭1[a  b, c]  𝔭1[(a  b)  c, d],
                          𝔭0[a  b, c]  𝔭1[(a  b)  c, d], 𝔭0[(a  b)  c, d]"
          using assms comp_cod_arr by simp
        also have "... = 𝔭0[a, b  (c  d)]  𝖺[a, b, c  d]  𝖺[a  b, c, d]"
          using assms assoc_def comp_assoc by simp
        finally show ?thesis by simp
      qed
    qed

    lemma inverse_arrows_assoc:
    assumes "ide a" and "ide b" and "ide c"
    shows "inverse_arrows 𝖺[a, b, c] 𝖺-1[a, b, c]"
      using assms assoc_def assoc'_def comp_assoc
      by (auto simp add: tuple_pr_arr)

    interpretation CC: product_category C C ..

    abbreviation Prod
    where "Prod fg  fst fg  snd fg"
    abbreviation Prod'
    where "Prod' fg  snd fg  fst fg"

    interpretation Π: binary_functor C C C Prod
      using tuple_ext CC.comp_char interchange
      apply unfold_locales
          apply auto
      by (metis prod_def seqE)+

    interpretation Prod': binary_functor C C C Prod'
      using tuple_ext CC.comp_char interchange
      apply unfold_locales
          apply auto
      by (metis prod_def seqE)+

    lemma binary_functor_Prod:
    shows "binary_functor C C C Prod" and "binary_functor C C C Prod'"
      ..

    definition sym ("𝗌[_, _]")
    where "𝗌[a1, a0]  if ide a0  ide a1 then 𝔭0[a1, a0], 𝔭1[a1, a0] else null"

    lemma sym_in_hom [intro]:
    assumes "ide a" and "ide b"
    shows "«𝗌[a, b] : a  b  b  a»"
      using assms sym_def by auto

    lemma sym_simps [simp]:
    assumes "ide a" and "ide b"
    shows "arr 𝗌[a, b]" and "dom 𝗌[a, b] = a  b" and "cod 𝗌[a, b] = b  a"
      using assms sym_in_hom by auto

    lemma comp_sym_tuple [simp]:
    assumes "«f0 : a  b0»" and "«f1 : a  b1»"
    shows "𝗌[b0, b1]  f0, f1 = f1, f0"
      using assms sym_def comp_tuple_arr by fastforce

    lemma prj_sym [simp]:
    assumes "ide a0" and "ide a1"
    shows "𝔭0[a1, a0]  𝗌[a0, a1] = 𝔭1[a0, a1]"
    and "𝔭1[a1, a0]  𝗌[a0, a1] = 𝔭0[a0, a1]"
      using assms sym_def by auto

    lemma comp_sym_sym [simp]:
    assumes "ide a0" and "ide a1"
    shows "𝗌[a1, a0]  𝗌[a0, a1] = (a0  a1)"
      using assms sym_def comp_tuple_arr by auto

    lemma sym_inverse_arrows:
    assumes "ide a0" and "ide a1"
    shows "inverse_arrows 𝗌[a0, a1] 𝗌[a1, a0]"
      using assms sym_in_hom comp_sym_sym by auto

    lemma sym_assoc_coherence:
    assumes "ide a" and "ide b" and "ide c"
    shows "𝖺[b, c, a]  𝗌[a, b  c]  𝖺[a, b, c] = (b  𝗌[a, c])  𝖺[b, a, c]  (𝗌[a, b]  c)"
      using assms sym_def assoc_def comp_assoc prod_tuple comp_cod_arr by simp

    lemma sym_naturality:
    assumes "«f0 : a0  b0»" and "«f1 : a1  b1»"
    shows "𝗌[b0, b1]  (f0  f1) = (f1  f0)  𝗌[a0, a1]"
      using assms sym_def comp_assoc prod_tuple by fastforce

    abbreviation σ
    where "σ fg  𝗌[cod (fst fg), cod (snd fg)]  (fst fg  snd fg)"

    interpretation σ: natural_transformation CC.comp C Prod Prod' σ
      using sym_def CC.arr_char CC.null_char comp_arr_dom comp_cod_arr
      apply unfold_locales
          apply auto
      using arr_cod_iff_arr ideD(1)
        apply metis
      using arr_cod_iff_arr ideD(1)
       apply metis
      using prod_tuple by simp

    lemma σ_is_natural_transformation:
    shows "natural_transformation CC.comp C Prod Prod' σ"
      ..

    abbreviation Diag
    where "Diag f  if arr f then (f, f) else CC.null"

    interpretation Δ: "functor" C CC.comp Diag
      by (unfold_locales, auto)

    lemma functor_Diag:
    shows "functor C CC.comp Diag"
      ..

    interpretation ΔoΠ: composite_functor CC.comp C CC.comp Prod Diag ..
    interpretation ΠoΔ: composite_functor C CC.comp C Diag Prod ..

    abbreviation π
    where "π  λ(f, g). (𝔭1[cod f, cod g]  (f  g), 𝔭0[cod f, cod g]  (f  g))"

    interpretation π: transformation_by_components CC.comp CC.comp ΔoΠ.map CC.map π
      using pr_naturality comp_arr_dom comp_cod_arr
      by unfold_locales auto

    lemma π_is_natural_transformation:
    shows "natural_transformation CC.comp CC.comp ΔoΠ.map CC.map π"
    proof -
      have "π.map = π"
        using π.map_def ext Π.is_extensional comp_arr_dom comp_cod_arr by auto
      thus "natural_transformation CC.comp CC.comp ΔoΠ.map CC.map π"
        using π.natural_transformation_axioms by simp
    qed

    interpretation δ: natural_transformation C C map ΠoΔ.map dup
      using dup_naturality comp_arr_dom comp_cod_arr prod_tuple tuple_ext
      by unfold_locales auto

    lemma dup_is_natural_transformation:
    shows "natural_transformation C C map ΠoΔ.map dup"
      ..

    interpretation ΔoΠoΔ: composite_functor C CC.comp CC.comp Diag ΔoΠ.map ..
    interpretation ΠoΔoΠ: composite_functor CC.comp C C Prod ΠoΔ.map ..

    interpretation Δoδ: natural_transformation C CC.comp Diag ΔoΠoΔ.map ‹Diag  dup›
    proof -
      have "Diag  map = Diag"
        by auto
      thus "natural_transformation C CC.comp Diag ΔoΠoΔ.map (Diag  dup)"
        using Δ.natural_transformation_axioms δ.natural_transformation_axioms o_assoc
              horizontal_composite [of C C map ΠoΔ.map dup CC.comp Diag Diag Diag]
        by metis
    qed

    interpretation δoΠ: natural_transformation CC.comp C Prod ΠoΔoΠ.map ‹dup  Prod›
      using δ.natural_transformation_axioms Π.natural_transformation_axioms o_assoc
            horizontal_composite [of CC.comp C Prod Prod Prod C map ΠoΔ.map dup]
      by simp

    interpretation πoΔ: natural_transformation C CC.comp ΔoΠoΔ.map Diag ‹π.map  Diag›
      using π.natural_transformation_axioms Δ.natural_transformation_axioms
            horizontal_composite
              [of C CC.comp Diag Diag Diag CC.comp ΔoΠ.map CC.map π.map]
      by simp

    interpretation Πoπ: natural_transformation CC.comp C ΠoΔoΠ.map Prod ‹Prod  π.map›
    proof -
      have "Prod  ΔoΠ.map = ΠoΔoΠ.map"
        by auto
      thus "natural_transformation CC.comp C ΠoΔoΠ.map Prod (Prod  π.map)"
        using π.natural_transformation_axioms Π.natural_transformation_axioms o_assoc
              horizontal_composite
                [of CC.comp CC.comp ΔoΠ.map CC.map π.map C Prod Prod Prod]
        by simp
    qed

    interpretation Δoδ_πoΔ: vertical_composite C CC.comp Diag ΔoΠoΔ.map Diag
                               ‹Diag  dup› ‹π.map  Diag›
      ..
    interpretation Πoπ_δoΠ: vertical_composite CC.comp C Prod ΠoΔoΠ.map Prod
                               ‹dup  Prod› ‹Prod  π.map›
      ..

    interpretation ΔΠ: unit_counit_adjunction CC.comp C Diag Prod dup π.map
    proof
      show "Δoδ_πoΔ.map = Diag"
      proof
        fix f
        have "¬ arr f  Δoδ_πoΔ.map f = Diag f"
          by (simp add: Δoδ_πoΔ.is_extensional)
        moreover have "arr f  Δoδ_πoΔ.map f = Diag f"
          using comp_cod_arr comp_assoc Δoδ_πoΔ.map_def by auto
        ultimately show "Δoδ_πoΔ.map f = Diag f" by blast
      qed
      show "Πoπ_δoΠ.map = Prod"
      proof
        fix fg
        show "Πoπ_δoΠ.map fg = Prod fg"
        proof -
          have "¬ CC.arr fg  ?thesis"
            by (simp add: Π.is_extensional Πoπ_δoΠ.is_extensional)
          moreover have "CC.arr fg  ?thesis"
          proof -
            assume fg: "CC.arr fg"
            have 1: "dup (Prod fg) = cod (fst fg)  cod (snd fg), cod (fst fg)  cod (snd fg) 
                                        (fst fg  snd fg)"
              using fg δ.is_natural_2
              apply simp
              by (metis (no_types, lifting) prod_simps(1) prod_simps(3))
            have "Πoπ_δoΠ.map fg =
                  (𝔭1[cod (fst fg), cod (snd fg)]  𝔭0[cod (fst fg), cod (snd fg)]) 
                    cod (fst fg)  cod (snd fg), cod (fst fg)  cod (snd fg) 
                    (fst fg  snd fg)"
              using fg 1 Πoπ_δoΠ.map_def comp_cod_arr by simp
            also have "... = ((𝔭1[cod (fst fg), cod (snd fg)]  𝔭0[cod (fst fg), cod (snd fg)]) 
                              cod (fst fg)  cod (snd fg), cod (fst fg)  cod (snd fg)) 
                             (fst fg  snd fg)"
              using comp_assoc by simp
            also have "... = 𝔭1[cod (fst fg), cod (snd fg)]  (cod (fst fg)  cod (snd fg)),
                              𝔭0[cod (fst fg), cod (snd fg)]  (cod (fst fg)  cod (snd fg)) 
                             (fst fg  snd fg)"
              using fg prod_tuple by simp
            also have "... = Prod fg"
              using fg comp_arr_dom Π.is_natural_2 by auto
            finally show ?thesis by simp
          qed
          ultimately show ?thesis by blast
        qed
      qed
    qed

    proposition induces_unit_counit_adjunction:
    shows "unit_counit_adjunction CC.comp C Diag Prod dup π.map"
      using ΔΠ.unit_counit_adjunction_axioms by simp

  end

  section "Category with Terminal Object"

  locale category_with_terminal_object =
    category +
  assumes has_terminal: "t. terminal t"

  locale elementary_category_with_terminal_object =
    category C
  for C :: "'a comp"                              (infixr "" 55)
  and one :: "'a"                                 ("𝟭")
  and trm :: "'a  'a"                           ("𝗍[_]") +
  assumes ide_one: "ide 𝟭"
  and trm_in_hom: "ide a  «𝗍[a] : a  𝟭»"
  and trm_eqI: " ide a; «f : a  𝟭»   f = 𝗍[a]"
  begin

    lemma trm_simps:
    assumes "ide a"
    shows "arr 𝗍[a]" and "dom 𝗍[a] = a" and "cod 𝗍[a] = 𝟭"
      using assms trm_in_hom by auto

    lemma trm_one:
    shows "𝗍[𝟭] = 𝟭"
    using ide_one trm_in_hom trm_eqI ide_in_hom by auto

    lemma terminal_one:
    shows "terminal 𝟭"
      using ide_one trm_in_hom trm_eqI terminal_def by metis

    lemma trm_naturality:
    assumes "arr f"
    shows "𝗍[cod f]  f = 𝗍[dom f]"
      using assms trm_eqI
      by (metis comp_in_homI' ide_cod ide_dom in_homE trm_in_hom)

    proposition is_category_with_terminal_object:
    shows "category_with_terminal_object C"
      apply unfold_locales
      using terminal_one by auto

  end

  context category_with_terminal_object
  begin

    definition some_terminal ("𝟭")
    where "some_terminal  SOME t. terminal t"

    definition "trm" ("𝗍[_]")
    where "𝗍[f]  if arr f then THE t. «t : dom f  𝟭» else null"

    lemma terminal_some_terminal [intro]:
    shows "terminal 𝟭"
      using some_terminal_def has_terminal someI_ex [of "λt. terminal t"] by presburger

    lemma ide_some_terminal:
    shows "ide 𝟭"
      using terminal_def by blast

    lemma trm_in_hom [intro]:
    assumes "arr f"
    shows "«𝗍[f] : dom f  𝟭»"
    proof -
      have "ide (dom f)" using assms by fastforce
      hence "∃!t. «t : dom f  𝟭»"
        using assms trm_def terminal_def terminal_some_terminal by simp
      thus ?thesis
        using assms trm_def [of f] theI' [of "λt. «t : dom f  𝟭»"] by auto
    qed

    lemma trm_simps [simp]:
    assumes "arr f"
    shows "arr 𝗍[f]" and "dom 𝗍[f] = dom f" and "cod 𝗍[f] = 𝟭"
      using assms trm_in_hom by auto

    lemma trm_eqI:
    assumes "«t : dom f  𝟭»"
    shows "t = 𝗍[f]"
    proof -
      have "ide (dom f)" using assms
        by (metis ide_dom in_homE)
      hence "∃!t. «t : dom f  𝟭»"
        using terminal_def [of 𝟭] terminal_some_terminal by auto
      moreover have "«t : dom f  𝟭»"
        using assms by simp
      ultimately show ?thesis
        using assms trm_def the1_equality [of "λt. «t : dom f  𝟭»" t]
              ‹ide (dom f) arr_dom_iff_arr
        by fastforce
    qed

    sublocale elementary_category_with_terminal_object C 𝟭 trm
      using ide_some_terminal trm_eqI
      by unfold_locales auto

    proposition extends_to_elementary_category_with_terminal_object:
      shows "elementary_category_with_terminal_object C 𝟭 trm"
      ..

  end

  section "Cartesian Category"

  locale cartesian_category =
    category_with_binary_products +
    category_with_terminal_object

  locale elementary_cartesian_category =
    elementary_category_with_binary_products +
    elementary_category_with_terminal_object
  begin

    proposition is_cartesian_category:
    shows "cartesian_category C"
      using cartesian_category.intro is_category_with_binary_products
            is_category_with_terminal_object
      by auto

  end

  context cartesian_category
  begin

    proposition extends_to_elementary_cartesian_category:
    shows "elementary_cartesian_category C pr0 pr1 𝟭 trm"
      by (simp add: elementary_cartesian_category_def
          elementary_category_with_terminal_object_axioms
          extends_to_elementary_category_with_binary_products)

    sublocale elementary_cartesian_category C pr0 pr1 𝟭 trm
      using extends_to_elementary_cartesian_category by simp

  end

  text ‹
    Here we prove some facts that will later allow us to show that an elementary cartesian
    category is a monoidal category.
  ›

  context elementary_cartesian_category
  begin

    abbreviation ι
    where "ι  𝔭0[𝟭, 𝟭]"

    lemma pr_coincidence:
    shows = 𝔭1[𝟭, 𝟭]"
      using ide_one
      by (simp add: terminal_arr_unique terminal_one)

    lemma ι_is_terminal_arr:
    shows "terminal_arr ι"
      using ide_one
      by (simp add: terminal_one)

    lemma inverse_arrows_ι:
    shows "inverse_arrows ι 𝟭, 𝟭"
      using ide_one
      by (metis (no_types, lifting) dup_is_natural_transformation ι_is_terminal_arr cod_pr0
          comp_cod_arr pr_dup(1) ide_dom inverse_arrows_def map_simp
          natural_transformation.is_natural_2 pr_simps(2) pr1_in_hom' trm_eqI trm_naturality
          trm_one tuple_pr)

    lemma ι_is_iso:
    shows "iso ι"
      using inverse_arrows_ι by auto

    lemma trm_tensor:
    assumes "ide a" and "ide b"
    shows "𝗍[a  b] = ι  (𝗍[a]  𝗍[b])"
    proof -
      have "𝗍[a  b] = 𝗍[a]  𝔭1[a, b]"
        by (metis assms(1-2) cod_pr1 pr_simps(4-6) trm_naturality)
      moreover have "«𝗍[b] : b  𝟭»"
        using assms(2) trm_in_hom by blast
      ultimately show ?thesis
        using assms(1) pr_coincidence trm_in_hom by fastforce
    qed

    abbreviation runit ("𝗋[_]")
    where "𝗋[a]  𝔭1[a, 𝟭]"

    abbreviation runit' ("𝗋-1[_]")
    where "𝗋-1[a]  a, 𝗍[a]"

    abbreviation lunit ("𝗅[_]")
    where "𝗅[a]  𝔭0[𝟭, a]"

    abbreviation lunit' ("𝗅-1[_]")
    where "𝗅-1[a]  𝗍[a], a"

    lemma runit_in_hom:
    assumes "ide a"
    shows "«𝗋[a] : a  𝟭  a»"
     using assms ide_one by simp

    lemma runit'_in_hom:
    assumes "ide a"
    shows "«𝗋-1[a] : a  a  𝟭»"
      using assms ide_in_hom trm_in_hom by blast

    lemma lunit_in_hom:
    assumes "ide a"
    shows "«𝗅[a] : 𝟭  a  a»"
     using assms ide_one by simp

    lemma lunit'_in_hom:
    assumes "ide a"
    shows "«𝗅-1[a] : a  𝟭  a»"
      using assms ide_in_hom trm_in_hom by blast

    lemma runit_naturality:
    assumes "ide a"
    shows "𝗋[cod a]  (a  𝟭) = a  𝗋[dom a]"
      using assms pr_naturality(2) ide_char ide_one by blast

    lemma inverse_arrows_runit:
    assumes "ide a"
    shows "inverse_arrows 𝗋[a] 𝗋-1[a]"
    proof
      show "ide (𝗋[a]  𝗋-1[a])"
      proof -
        have "𝗋[a]  𝗋-1[a] = a"
          using assms
          by (metis in_homE ide_char pr_tuple(1) trm_in_hom)
        thus ?thesis
          using assms by presburger
      qed
      show "ide (𝗋-1[a]  𝗋[a])"
      proof -
        have "ide (a  𝟭)"
          using assms ide_one by blast
        moreover have "𝗋-1[a]  𝗋[a] = a  𝟭"
        proof (intro pr_joint_monic [of a 𝟭 "𝗋-1[a]  𝗋[a]" "a  𝟭"])
          show "seq 𝔭0[a, 𝟭] (𝗋-1[a]  𝗋[a])"
            using assms ide_one runit'_in_hom [of a]
            by (intro seqI) auto
          show "𝔭0[a, 𝟭]  𝗋-1[a]  𝗋[a] = 𝔭0[a, 𝟭]  (a  𝟭)"
          proof -
            have "𝔭0[a, 𝟭]  𝗋-1[a]  𝗋[a] = (𝔭0[a, 𝟭]  𝗋-1[a])  𝗋[a]"
              using comp_assoc by simp
            also have "... = 𝗍[a]  𝗋[a]"
              using assms ide_one
              by (metis in_homE pr_tuple(2) ide_char trm_in_hom)
            also have "... = 𝗍[a  𝟭]"
              using assms ide_one trm_naturality [of "𝗋[a]"] by simp
            also have "... = 𝔭0[a, 𝟭]  (a  𝟭)"
              using assms comp_arr_dom ide_one trm_naturality trm_one by fastforce
            finally show ?thesis by blast
          qed
          show "𝔭1[a, 𝟭]  𝗋-1[a]  𝗋[a] = 𝔭1[a, 𝟭]  (a  𝟭)"
            using assms
            by (metis ‹ide (𝗋[a]  𝗋-1[a]) cod_comp cod_pr1 dom_comp ide_compE ide_one
                comp_assoc runit_naturality)
        qed
        ultimately show ?thesis by simp
      qed
    qed

    lemma lunit_naturality:
    assumes "arr f"
    shows "C 𝗅[cod f] (𝟭  f) = C f 𝗅[dom f]"
      using assms pr_naturality(1) ide_char ide_one by blast

    lemma inverse_arrows_lunit:
    assumes "ide a"
    shows "inverse_arrows 𝗅[a] 𝗅-1[a]"
    proof
      show "ide (C 𝗅[a] 𝗅-1[a])"
      proof -
        have "C 𝗅[a] 𝗅-1[a] = a"
          using assms
          by (metis ide_char in_homE pr_tuple(2) trm_in_hom)
        thus ?thesis
          using assms by simp
      qed
      show "ide (𝗅-1[a]  𝗅[a])"
      proof -
        have "𝗅-1[a]  𝗅[a] = 𝟭  a"
        proof (intro pr_joint_monic [of 𝟭 a "𝗅-1[a]  𝗅[a]" "𝟭  a"])
          show "seq 𝗅[a] (𝗅-1[a]  𝗅[a])"
            using assms ‹ide (𝗅[a]  𝗅-1[a]) by blast
          show "𝗅[a]  𝗅-1[a]  𝗅[a] = 𝗅[a]  (𝟭  a)"
            using assms
            by (metis ‹ide (𝗅[a]  𝗅-1[a]) cod_comp cod_pr0 dom_cod ide_compE ide_one
                comp_assoc lunit_naturality)
          show "𝔭1[𝟭, a]  𝗅-1[a]  𝗅[a] = 𝔭1[𝟭, a]  (𝟭  a)"
          proof -
            have "𝔭1[𝟭, a]  𝗅-1[a]  𝗅[a] = (𝔭1[𝟭, a]  𝗅-1[a])  𝗅[a]"
              using comp_assoc by simp
            also have "... = 𝗍[a]  𝗅[a]"
              using assms ide_one
              by (metis pr_tuple(1) ide_char in_homE trm_in_hom)
            also have "... = 𝗍[𝟭  a]"
              using assms ide_one trm_naturality [of "𝗅[a]"] by simp
            also have "... = 𝔭1[𝟭, a]  (𝟭  a)"
              using assms comp_arr_dom ide_one trm_naturality trm_one by fastforce
            finally show ?thesis by simp
          qed
        qed
        moreover have "ide (𝟭  a)"
          using assms ide_one by simp
        finally show ?thesis by blast
      qed
    qed

    lemma comp_lunit_term_dup:
    assumes "ide a"
    shows "𝗅[a]  (𝗍[a]  a)  𝖽[a] = a"
    proof -
      have "«𝗍[a] : a  𝟭»"
        using assms trm_in_hom by blast
      hence "𝗅[a]  (𝗍[a]  a) = a  𝔭0[a, a]"
        by (metis assms pr_naturality(1) ide_char in_homE)
      thus ?thesis
        by (metis (no_types) assms comp_assoc comp_ide_self pr_dup(1))
    qed

    lemma comp_runit_term_dup:
    assumes "ide a"
    shows "𝗋[a]  (a  𝗍[a])  𝖽[a] = a"
    proof -
      have "«𝗍[a] : a  𝟭»"
        using assms trm_in_hom by blast
      hence "𝗋[a]  (a  𝗍[a]) = a  𝔭1[a, a]"
        using assms by auto
      thus ?thesis
        using assms
        by (metis comp_ide_arr pr_dup(2) ide_char comp_assoc seqI)
    qed

    lemma comp_proj_assoc:
    assumes "ide a0" and "ide a1" and "ide a2"
    shows "𝔭1[a0, a1  a2]  𝖺[a0, a1, a2] = 𝔭1[a0, a1]  𝔭1[a0  a1, a2]"
    and "𝔭0[a0, a1  a2]  𝖺[a0, a1, a2] = 𝔭0[a0, a1]  𝔭1[a0  a1, a2], 𝔭0[a0  a1, a2]"
      using assms assoc_def by auto

    lemma dup_coassoc:
    assumes "ide a"
    shows "𝖺[a, a, a]  (𝖽[a]  a)  𝖽[a] = (a  𝖽[a])  𝖽[a]"
    proof (intro pr_joint_monic
                   [of a "a  a" "𝖺[a, a, a]  (𝖽[a]  a)  𝖽[a]" "(a  𝖽[a])  𝖽[a]"])
      show "seq 𝔭0[a, a  a] (𝖺[a, a, a]  (𝖽[a]  a)  𝖽[a])"
        using assms by simp
      show "𝔭0[a, a  a]  𝖺[a, a, a]  (𝖽[a]  a)  𝖽[a] = 𝔭0[a, a  a]  (a  𝖽[a])  𝖽[a]"
      proof -
        have "𝔭0[a, a  a]  𝖺[a, a, a]  (𝖽[a]  a)  𝖽[a] =
              ((𝔭0[a, a  a]  𝖺[a, a, a])  (𝖽[a]  a))  𝖽[a]"
          using comp_assoc by simp
        also have "... = ((𝔭0[a, a]  𝔭1[a  a, a])  (𝖽[a]  a))  𝖽[a], (a  𝔭0[a, a])  𝖽[a]"
          using assms assoc_def by simp
        also have "... = 𝖽[a]"
          using assms comp_assoc by simp
        also have "... = (𝔭0[a, a  a]  (a  𝖽[a]))  𝖽[a]"
          using assms assoc_def comp_assoc by simp
        also have "... = 𝔭0[a, a  a]  (a  𝖽[a])  𝖽[a]"
          using comp_assoc by simp
        finally show ?thesis by blast
      qed
      show "𝔭1[a, a  a]  𝖺[a, a, a]  (𝖽[a]  a)  𝖽[a] = 𝔭1[a, a  a]  (a  𝖽[a])  𝖽[a]"
      proof -
        have "𝔭1[a, a  a]  𝖺[a, a, a]  (𝖽[a]  a)  𝖽[a] =
              ((𝔭1[a, a  a]  𝖺[a, a, a])  (𝖽[a]  a))  𝖽[a]"
          using comp_assoc by simp
        also have "... = ((𝔭1[a, a]  𝔭1[a  a, a])  (𝖽[a]  a))  𝖽[a]"
          using assms assoc_def by simp
        also have "... = a"
          using assms comp_assoc by simp
        also have "... = (a  𝔭1[a, a])  𝖽[a]"
          using assms comp_assoc by simp
        also have "... = (𝔭1[a, a  a]  (a  𝖽[a]))  𝖽[a]"
          using assms by simp
        also have "... = 𝔭1[a, a  a]  (a  𝖽[a])  𝖽[a]"
          using comp_assoc by simp
        finally show ?thesis by blast
      qed
    qed

    lemma comp_assoc_tuple:
    assumes "«f0 : a  b0»" and "«f1 : a  b1»" and "«f2 : a  b2»"
    shows "𝖺[b0, b1, b2]  f0, f1, f2 = f0, f1, f2"
    and "𝖺-1[b0, b1, b2]  f0, f1, f2 = f0, f1, f2"
      using assms assoc_def assoc'_def comp_assoc by fastforce+

    lemma dup_tensor:
    assumes "ide a" and "ide b"
    shows "𝖽[a  b] = 𝖺-1[a, b, a  b]  (a  𝖺[b, a, b])  (a  σ (a, b)  b) 
                        (a  𝖺-1[a, b, b])  𝖺[a, a, b  b]  (𝖽[a]  𝖽[b])"
    proof (intro pr_joint_monic [of "a  b" "a  b" "𝖽[a  b]"])
      show "seq 𝔭0[a  b, a  b] (𝖽[a  b])"
        using assms by simp
      have 1: "𝖺-1[a, b, a  b]  (a  𝖺[b, a, b])  (a  σ (a, b)  b) 
                 (a  𝖺-1[a, b, b])  𝖺[a, a, b  b]  (𝖽[a]  𝖽[b]) =
               a  b, a  b"
      proof -
        have "𝖺-1[a, b, a  b]  (a  𝖺[b, a, b])  (a  σ (a, b)  b) 
              (a  𝖺-1[a, b, b])  𝖺[a, a, b  b]  (𝖽[a]  𝖽[b])
                = 𝖺-1[a, b, a  b]  (a  𝖺[b, a, b])  (a  σ (a, b)  b) 
                  (a  𝖺-1[a, b, b])  𝔭1[a, b], 𝔭1[a, b], 𝖽[b]  𝔭0[a, b]"
        proof -
          have "𝖺[a, a, b  b]  (𝖽[a]  𝖽[b]) = 𝔭1[a, b], 𝔭1[a, b], 𝖽[b]  𝔭0[a, b]"
            using assms assoc_def comp_assoc pr_naturality comp_cod_arr by simp
          thus ?thesis by presburger
        qed
        also have "... = 𝖺-1[a, b, a  b] 
        a  a  a  𝔭1[a, b], 𝖺[b, a, b]  (𝗌[a, b]  (a  b)  b) 
                               𝖺-1[a, b, b]  𝔭1[a, b], 𝖽[b  𝔭0[a, b]]"
          using assms prod_tuple by simp
        also have "... = 𝖺-1[a, b, a  b] 
        𝔭1[a, b], 𝖺[b, a, b]  (𝗌[a, b]  b)  𝖺-1[a, b, b]  𝔭1[a, b], 𝖽[𝔭0[a, b]]"
        proof -
          have "a  a  a  𝔭1[a, b] = 𝔭1[a, b]"
            using assms comp_cod_arr by simp
          moreover have "b  𝔭0[a, b] = 𝔭0[a, b]"
            using assms comp_cod_arr by simp
          moreover have "𝗌[a, b]  (a  b)  b = 𝗌[a, b]  b"
            using assms comp_arr_dom by simp
          ultimately show ?thesis by simp
        qed
        also have "... = 𝖺-1[a, b, a  b]  𝔭1[a, b], 𝖺[b, a, b]  (𝗌[a, b]  b) 
                           𝔭1[a, b], 𝔭0[a, b], 𝔭0[a, b]"
        proof -
          have "𝖺-1[a, b, b]  𝔭1[a, b], 𝖽[𝔭0[a, b]] = 𝔭1[a, b], 𝔭0[a, b], 𝔭0[a, b]"
            using assms comp_assoc_tuple(2) by blast
          thus ?thesis by simp
        qed
        also have "... = 𝖺-1[a, b, a  b]  𝔭1[a, b], 𝖺[b, a, b]  𝗌[a, b], 𝔭0[a, b]"
          using assms prod_tuple comp_arr_dom comp_cod_arr by simp
        also have "... = 𝖺-1[a, b, a  b]  𝔭1[a, b], 𝔭0[a, b], 𝔭1[a, b], 𝔭0[a, b]"
          using assms comp_assoc_tuple(1)
          by (metis sym_def pr_in_hom)
        also have "... = 𝔭1[a, b], 𝔭0[a, b], 𝔭1[a, b], 𝔭0[a, b]"
          using assms comp_assoc_tuple(2) by force
        also have "... = 𝖽[a  b]"
          using assms by simp
        finally show ?thesis by simp
      qed
      show "𝔭0[a  b, a  b]  𝖽[a  b]
              = 𝔭0[a  b, a  b] 
                𝖺-1[a, b, a  b]  (a  𝖺[b, a, b])  (a  σ (a, b)  b) 
                (a  𝖺-1[a, b, b])  𝖺[a, a, b  b]  (𝖽[a]  𝖽[b])"
        using assms 1 by force
      show "𝔭1[a  b, a  b]  𝖽[a  b]
              = 𝔭1[a  b, a  b] 
                𝖺-1[a, b, a  b]  (a  𝖺[b, a, b])  (a  σ (a, b)  b) 
                (a  𝖺-1[a, b, b])  𝖺[a, a, b  b]  (𝖽[a]  𝖽[b])"
        using assms 1 by force
    qed

    (* TODO: Not sure if the remaining facts are useful. *)

    lemma ι_eq_trm:
    shows = 𝗍[𝟭  𝟭]"
    proof (intro terminal_arr_unique)
      show "par ι 𝗍[𝟭  𝟭]"
        by (simp add: ide_one trm_one trm_tensor)
      show "terminal_arr 𝗍[𝟭  𝟭]"
        using ide_one ι_is_terminal_arr ‹par ι 𝗍[𝟭  𝟭] by auto
      show "terminal_arr ι"
        using ι_is_terminal_arr by blast
    qed

    lemma terminal_tensor_one_one:
    shows "terminal (𝟭  𝟭)"
    proof
      show "ide (𝟭  𝟭)"
        using ide_one by simp
      show "a. ide a  ∃!f. «f : a  𝟭  𝟭»"
      proof -
        fix a
        assume a: "ide a"
        show "∃!f. «f : a  𝟭  𝟭»"
        proof
          show "«inv ι  𝗍[a] : a  𝟭  𝟭»"
            using a ide_one inverse_arrows_ι inverse_unique trm_in_hom by fastforce
          show "f. «f : a  𝟭  𝟭»  f = inv ι  𝗍[a]"
          proof -
            fix f
            assume f: "«f : a  𝟭  𝟭»"
            have  f = 𝗍[a]"
            proof (intro terminal_arr_unique)
              show "par (ι  f) 𝗍[a]"
                using a f
                by (metis ι_is_iso ι_is_terminal_arr «inv ι  𝗍[a] : a  𝟭  𝟭»
                    cod_comp dom_comp dom_inv ide_one in_homE pr_simps(2-3) seqE seqI)
              show "terminal_arr (ι  f)"
                using a f ι_is_terminal_arr cod_comp by force
              show "terminal_arr 𝗍[a]"
                using a ‹par (ι  f) 𝗍[a] ‹terminal_arr (ι  f) by auto
            qed
            thus "f = inv ι  𝗍[a]"
              using a f ι_is_iso invert_side_of_triangle(1)
                    «inv ι  𝗍[a] : a  𝟭  𝟭»
              by blast
          qed
        qed
      qed
    qed

  end

  section "Category with Finite Products"

  text ‹
    In this last section, we show that the notion ``cartesian category'', which we defined
    to be a category with binary products and terminal object, coincides with the notion
    ``category with finite products''.  Due to the inability to quantify over types in HOL,
    we content ourselves with defining the latter notion as "has I›-indexed products
    for every finite set I› of natural numbers."  We can transfer this property to finite
    sets at other types using the fact that products are preserved under bijections of
    the index sets.
  ›

  locale category_with_finite_products =
    category C
  for C :: "'c comp" +
  assumes has_finite_products: "finite (I :: nat set)  has_products I"
  begin

    lemma has_finite_products':
    assumes "I  UNIV"
    shows "finite I  has_products I"
    proof -
      assume I: "finite I"
      obtain n φ where φ: "bij_betw φ {k. k < (n :: nat)} I"
        using I finite_imp_nat_seg_image_inj_on inj_on_imp_bij_betw by fastforce
      show "has_products I"
        using assms(1) φ has_finite_products has_products_preserved_by_bijection
              category_with_finite_products.has_finite_products
        by blast
    qed

  end

  lemma (in category) has_binary_products_if:
  assumes "has_products ({0, 1} :: nat set)"
  shows "has_binary_products"
  proof (unfold has_binary_products_def)
    show "a0 a1. ide a0  ide a1  (p0 p1. has_as_binary_product a0 a1 p0 p1)"
    proof (intro allI impI)
      fix a0 a1
      assume 1: "ide a0  ide a1"
      show "p0 p1. has_as_binary_product a0 a1 p0 p1"
      proof -
        interpret J: binary_product_shape
          by unfold_locales
        interpret D: binary_product_diagram C a0 a1
          using 1 by unfold_locales auto
        interpret discrete_diagram J.comp C D.map
          using J.is_discrete
          by unfold_locales auto
        show "p0 p1. has_as_binary_product a0 a1 p0 p1"
        proof (unfold has_as_binary_product_def)
          text ‹
            Here we have to work around the fact that has_finite_products› is defined
            in terms of @{typ "nat set"}, whereas has_as_binary_product› is defined
            in terms of J.arr set›.
          ›
          let  = "(λx :: nat. if x = 0 then J.FF else J.TT)"
          let  = "λj. if j = J.FF then 0 else 1"
          have "bij_betw  ({0, 1} :: nat set) {J.FF, J.TT}"
            using bij_betwI [of  "{0, 1} :: nat set" "{J.FF, J.TT}" ] by fastforce
          hence "has_products {J.FF, J.TT}"
            using assms has_products_def [of "{J.FF, J.TT}"]
                  has_products_preserved_by_bijection
                    [of "{0, 1} :: nat set"  "{J.FF, J.TT}"]
            by blast
          hence "a. has_as_product J.comp D.map a"
            using has_products_def [of "{J.FF, J.TT}"]
                  discrete_diagram_axioms J.arr_char
            by blast
          hence "a π. product_cone J.comp C D.map a π"
            using has_as_product_def by blast
          hence 2: "a π. D.limit_cone a π"
            unfolding product_cone_def by simp
          obtain a π where π: "D.limit_cone a π"
            using 2 by auto
          interpret π: limit_cone J.comp C D.map a π
            using π by auto
          have "π = D.mkCone (π J.FF) (π J.TT)"
          proof -
            have "a. J.ide a  π a = D.mkCone (π J.FF) (π J.TT) a"
              using D.mkCone_def J.ide_char by auto
            moreover have "a = dom (π J.FF)"
              by simp
            moreover have "D.cone a (D.mkCone (π (J.MkIde False)) (π (J.MkIde True)))"
              using 1 D.cone_mkCone [of "π J.FF" "π J.TT"] by auto
            ultimately show ?thesis
              using D.mkCone_def π.natural_transformation_axioms
                    D.cone_mkCone [of "π J.FF" "π J.TT"]
                    NaturalTransformation.eqI
                      [of "J.comp" C π.A.map "D.map" π "D.mkCone (π J.FF) (π J.TT)"]
                    cone_def [of J.comp C D.map a "D.mkCone (π J.FF) (π J.TT)"] J.ide_char
              by blast
          qed
          hence "D.limit_cone (dom (π J.FF)) (D.mkCone (π J.FF) (π J.TT))"
            using π.limit_cone_axioms by simp
          thus "p0 p1. ide a0  ide a1  D.has_as_binary_product p0 p1"
            using 1 by blast
        qed
      qed
    qed
  qed

  sublocale category_with_finite_products  category_with_binary_products C
    using has_binary_products_if has_finite_products
    by (unfold_locales, unfold has_binary_products_def) simp

  proposition (in category_with_finite_products) is_category_with_binary_products:
  shows "category_with_binary_products C"
    ..

  sublocale category_with_finite_products  category_with_terminal_object C
  proof
    interpret J: discrete_category "{} :: nat set"
      by unfold_locales auto
    interpret D: empty_diagram J.comp C "λj. null"
      by unfold_locales auto
    interpret D: discrete_diagram J.comp C "λj. null"
      using J.is_discrete by unfold_locales auto
    have "a. D.has_as_limit a  has_as_product J.comp (λj. null) a"
      using product_cone_def J.category_axioms category_axioms D.discrete_diagram_axioms
            has_as_product_def product_cone_def
      by metis
    moreover have "a. has_as_product J.comp (λj. null) a"
      using has_finite_products [of "{} :: nat set"] has_products_def [of "{} :: nat set"]
            D.discrete_diagram_axioms
      by blast
    ultimately have "a. D.has_as_limit a" by blast
    thus "a. terminal a" using D.has_as_limit_iff_terminal by blast
  qed

  proposition (in category_with_finite_products) is_category_with_terminal_object:
  shows "category_with_terminal_object C"
    ..

  sublocale category_with_finite_products  cartesian_category ..

  proposition (in category_with_finite_products) is_cartesian_category:
  shows "cartesian_category C"
    ..

  context category
  begin

    lemma binary_product_of_products_is_product:
    assumes "has_as_product J0 D0 a0" and "has_as_product J1 D1 a1"
    and "has_as_binary_product a0 a1 p0 p1"
    and "Collect (partial_magma.arr J0)  Collect (partial_magma.arr J1) = {}"
    and "partial_magma.null J0 = partial_magma.null J1"
    shows "has_as_product
             (discrete_category.comp
                (Collect (partial_magma.arr J0)  Collect (partial_magma.arr J1))
                (partial_magma.null J0))
             (λi. if i  Collect (partial_magma.arr J0) then D0 i
                  else if i  Collect (partial_magma.arr J1) then D1 i
                  else null)
             (dom p0)"
    proof -
      obtain π0 where π0: "product_cone J0 (⋅) D0 a0 π0"
        using assms(1) has_as_product_def by blast
      obtain π1 where π1: "product_cone J1 (⋅) D1 a1 π1"
        using assms(2) has_as_product_def by blast
      interpret J0: category J0
        using π0 product_cone.axioms(1) by metis
      interpret J1: category J1
        using π1 product_cone.axioms(1) by metis
      interpret D0: discrete_diagram J0 C D0
        using π0 product_cone.axioms(3) by metis
      interpret D1: discrete_diagram J1 C D1
        using π1 product_cone.axioms(3) by metis
      interpret π0: product_cone J0 C D0 a0 π0
        using π0 by auto
      interpret π1: product_cone J1 C D1 a1 π1
        using π1 by auto
      interpret J: discrete_category ‹Collect J0.arr  Collect J1.arr› J0.null
        using J0.not_arr_null assms(5) by unfold_locales auto
      interpret X: binary_product_shape .
      interpret a0xa1: binary_product_diagram C a0 a1
        using assms(3) has_as_binary_product_def
        by (simp add: binary_product_diagram.intro binary_product_diagram_axioms.intro
            category_axioms)
      have p0p1: "a0xa1.has_as_binary_product p0 p1"
        using assms(3) has_as_binary_product_def [of a0 a1 p0 p1] by simp

      let ?D = "(λi. if i  Collect J0.arr then D0 i
                     else if i  Collect J1.arr then D1 i
                     else null)"
      let ?a = "dom p0"
      let  = "λi. if i  Collect J0.arr then π0 i  p0
                    else if i  Collect J1.arr then π1 i  p1
                    else null"

      let ?p0p1 = "a0xa1.mkCone p0 p1"
      interpret p0p1: limit_cone X.comp C a0xa1.map ?a ?p0p1
        using p0p1 by simp
      have a: "ide ?a"
        using p0p1.ide_apex by simp
      have p0: "«p0 : ?a  a0»"
        using a0xa1.mkCone_def p0p1.preserves_hom [of X.FF X.FF X.FF] X.ide_char X.ide_in_hom
        by auto
      have p1: "«p1 : ?a  a1»"
        using a0xa1.mkCone_def p0p1.preserves_hom [of X.TT X.TT X.TT] X.ide_char X.ide_in_hom
        by auto

      interpret D: discrete_diagram J.comp C ?D
        using assms J.arr_char J.dom_char J.cod_char J.is_discrete D0.is_discrete D1.is_discrete
              J.cod_comp J.seq_char
        by unfold_locales auto
      interpret A: constant_functor J.comp C ?a
        using p0p1.ide_apex by unfold_locales simp
      interpret π: natural_transformation J.comp C A.map ?D 
      proof
        fix j
        show "¬ J.arr j   j = null"
          by simp
        assume j: "J.arr j"
        have π0j: "J0.arr j  «π0 j : a0  D0 j»"
          using D0.is_discrete by auto
        have π1j: "J1.arr j  «π1 j : a1  D1 j»"
          using D1.is_discrete by auto
        show "dom ( j) = A.map (J.dom j)"
          using j J.arr_char p0 p1 π0j π1j
          by fastforce
        show "cod ( j) = ?D (J.cod j)"
          using j J.arr_char p0 p1 π0j π1j
          by fastforce
        show "?D j   (J.dom j) =  j"
        proof -
          have 0: "J0.arr j  D0 j  π0 j  p0 = π0 j  p0"
          proof -
            have "J0.arr j  (D0 j  π0 j)  p0 = π0 j  p0"
              using p0 π0.is_natural_1 π0.is_natural_2 D0.is_discrete by simp
            thus "J0.arr j  D0 j  π0 j  p0 = π0 j  p0"
              using comp_assoc by simp
          qed
          have 1: "J1.arr j  D1 j  π1 j  p1 = π1 j  p1"
          proof -
            have "J1.arr j  (D1 j  π1 j)  p1 = π1 j  p1"
              using p1 π1.is_natural_1 π1.is_natural_2 D1.is_discrete by simp
            thus "J1.arr j  D1 j  π1 j  p1 = π1 j  p1"
              using comp_assoc by simp
          qed
          show ?thesis
            using 0 1 by auto
        qed
        show " (J.cod j)  A.map j =  j"
          using j comp_arr_dom p0 p1 comp_assoc by auto
      qed
      interpret π: cone J.comp C ?D ?a  ..
      interpret π: product_cone J.comp C ?D ?a 
      proof
        show "a' χ'. D.cone a' χ'  ∃!f. «f : a'  ?a»  D.cones_map f  = χ'"
        proof -
          fix a' χ'
          assume χ': "D.cone a' χ'"
          interpret χ': cone J.comp C ?D a' χ'
            using χ' by simp
          show "∃!f. «f : a'  ?a»  D.cones_map f  = χ'"
          proof
            let ?χ0' = "λi. if i  Collect J0.arr then χ' i else null"
            let ?χ1' = "λi. if i  Collect J1.arr then χ' i else null"
            have 0: "i. i  Collect J0.arr  χ' i  hom a' (D0 i)"
              using J.arr_char by auto
            have 1: "i. i  Collect J1.arr  χ' i  hom a' (D1 i)"
              using J.arr_char ‹Collect J0.arr  Collect J1.arr = {} by force
            interpret A0': constant_functor J0 C a'
              apply unfold_locales using χ'.ide_apex by auto
            interpret A1': constant_functor J1 C a'
              apply unfold_locales using χ'.ide_apex by auto
            interpret χ0': cone J0 C D0 a' ?χ0'
            proof (unfold_locales)
              fix j
              show "¬ J0.arr j  (if j  Collect J0.arr then χ' j else null) = null"
                by simp
              assume j: "J0.arr j"
              show 0: "dom (?χ0' j) = A0'.map (J0.dom j)"
                using j by simp
              show 1: "cod (?χ0' j) = D0 (J0.cod j)"
                using j J.arr_char J.cod_char D0.is_discrete by simp
              show "D0 j  (?χ0' (J0.dom j)) = ?χ0' j"
                using 1 j J.arr_char D0.is_discrete comp_cod_arr by simp
              show "?χ0' (J0.cod j)  A0'.map j = ?χ0' j"
                using 0 j J.arr_char D0.is_discrete comp_arr_dom by simp
            qed
            interpret χ1': cone J1 C D1 a' ?χ1'
            proof (unfold_locales)
              fix j
              show "¬ J1.arr j  (if j  Collect J1.arr then χ' j else null) = null"
                by simp
              assume j: "J1.arr j"
              show 0: "dom (?χ1' j) = A1'.map (J1.dom j)"
                using j by simp
              show 1: "cod (?χ1' j) = D1 (J1.cod j)"
                using assms(4) j J.arr_char J.cod_char D1.is_discrete by auto
              show "D1 j  (?χ1' (J1.dom j)) = ?χ1' j"
                using 1 j J.arr_char D1.is_discrete comp_cod_arr by simp
              show "?χ1' (J1.cod j)  A1'.map j = ?χ1' j"
                using 0 j J.arr_char D1.is_discrete comp_arr_dom by simp
            qed
            define f0 where "f0 = π0.induced_arrow a' ?χ0'"
            define f1 where "f1 = π1.induced_arrow a' ?χ1'"
            have f0: "«f0 : a'  a0»"
              using f0_def π0.induced_arrowI χ0'.cone_axioms by simp
            have f1: "«f1 : a'  a1»"
              using f1_def π1.induced_arrowI χ1'.cone_axioms by simp
            have 2: "a0xa1.is_rendered_commutative_by f0 f1"
              using f0 f1 by auto

            interpret p0p1: binary_product_cone C a0 a1 p0 p1 ..
            interpret f0f1: cone X.comp C a0xa1.map a' ‹a0xa1.mkCone f0 f1
              using 2 f0 f1 a0xa1.cone_mkCone [of f0 f1] by auto
            define f where "f = p0p1.induced_arrow a' (a0xa1.mkCone f0 f1)"

            have f: "«f : a'  ?a»"
              using f_def 2 f0 f1 p0p1.induced_arrowI'(1) by auto
            moreover have χ': "D.cones_map f  = χ'"
            proof
              fix j
              show "D.cones_map f  j = χ' j"
              proof (cases "J0.arr j", cases "J1.arr j")
                show "J0.arr j; J1.arr j  D.cones_map f  j = χ' j"
                  using assms(4) by auto
                show "J0.arr j; ¬ J1.arr j  D.cones_map f  j = χ' j"
                proof -
                  assume J0: "J0.arr j" and J1: "¬ J1.arr j"
                  have "D.cones_map f  j = (π0 j  p0)  f"
                    using f J0 J1 π.cone_axioms by auto
                  also have "... = π0 j  p0  f"
                    using comp_assoc by simp
                  also have "... = π0 j  f0"
                    using 2 f0 f1 f_def p0p1.induced_arrowI' by auto
                  also have "... = χ' j"
                  proof -
                    have "π0 j  f0 = π0 j  π0.induced_arrow' a' χ'"
                      unfolding f0_def by simp
                    also have "... = (λj. if J0.arr j then
                                            π0 j  π0.induced_arrow a'
                                                    (λi. if i  Collect J0.arr then χ' i else null)
                                          else null) j"
                      using J0 by simp
                    also have "... = D0.mkCone χ' j"
                    proof -
                      have "(λj. if J0.arr j then
                                    π0 j  π0.induced_arrow a'
                                             (λi. if i  Collect J0.arr then χ' i else null)
                                 else null) =
                            D0.mkCone χ'"
                        using f0 f0_def π0.induced_arrowI(2) [of ?χ0' a'] J0
                              D0.mkCone_cone χ0'.cone_axioms π0.cone_axioms J0
                        by auto
                      thus ?thesis by meson
                    qed
                    also have "... = χ' j"
                      using J0 by simp
                    finally show ?thesis by blast
                  qed
                  finally show ?thesis by simp
                qed
                show "¬ J0.arr j  D.cones_map f  j = χ' j"
                proof (cases "J1.arr j")
                  show "¬ J0.arr j; ¬ J1.arr j  D.cones_map f  j = χ' j"
                    using f π.cone_axioms χ'.is_extensional by auto
                  show "¬ J0.arr j; J1.arr j  D.cones_map f  j = χ' j"
                  proof -
                    assume J0: "¬ J0.arr j" and J1: "J1.arr j"
                    have "D.cones_map f  j = (π1 j  p1)  f"
                      using J0 J1 f π.cone_axioms by auto
                    also have "... = π1 j  p1  f"
                      using comp_assoc by simp
                    also have "... = π1 j  f1"
                      using 2 f0 f1 f_def p0p1.induced_arrowI' by auto
                    also have "... = χ' j"
                    proof -
                      have "π1 j  f1 = π1 j  π1.induced_arrow' a' χ'"
                        unfolding f1_def by simp
                      also have "... = (λj. if J1.arr j then
                                              π1 j  π1.induced_arrow a'
                                                      (λi. if i  Collect J1.arr
                                                           then χ' i else null)
                                            else null) j"
                        using J1 by simp
                      also have "... = D1.mkCone χ' j"
                      proof -
                        have "(λj. if J1.arr j then
                                      π1 j  π1.induced_arrow a'
                                               (λi. if i  Collect J1.arr then χ' i else null)
                                   else null) =
                              D1.mkCone χ'"
                          using f1 f1_def π1.induced_arrowI(2) [of ?χ1' a'] J1
                                D1.mkCone_cone [of a' χ'] χ1'.cone_axioms π1.cone_axioms J1
                          by auto
                        thus ?thesis by meson
                      qed
                      also have "... = χ' j"
                        using J1 by simp
                      finally show ?thesis by blast
                    qed
                    finally show ?thesis by simp
                  qed
                qed
              qed
            qed
            ultimately show "«f : a'  ?a»  D.cones_map f  = χ'" by blast
            show "f'. «f' : a'  ?a»  D.cones_map f'  = χ'  f' = f"
            proof -
              fix f'
              assume f': "«f' : a'  ?a»  D.cones_map f'  = χ'"
              let ?f0' = "p0  f'"
              let ?f1' = "p1  f'"
              have 1: "a0xa1.is_rendered_commutative_by ?f0' ?f1'"
                using f' p0 p1 p0p1.renders_commutative seqI' by auto
              have f0': "«?f0' : a'  a0»"
                using f' p0 by auto
              have f1': "«?f1' : a'  a1»"
                using f' p1 by auto
              have "p0  f = p0  f'"
              proof -
                have "D0.cones_map (p0  f) π0 = ?χ0'"
                  using f p0 π0.cone_axioms χ' π.cone_axioms comp_assoc assms(4) seqI'
                  by fastforce
                moreover have "D0.cones_map (p0  f') π0 = ?χ0'"
                  using f' p0 π0.cone_axioms π.cone_axioms comp_assoc assms(4) seqI'
                  by fastforce
                moreover have "p0  f = f0"
                  using 2 f0 f_def p0p1.induced_arrowI'(2) by blast
                ultimately show ?thesis
                  using f0 f0' χ0'.cone_axioms π0.is_universal [of a'] by auto
              qed
              moreover have "p1  f = p1  f'"
              proof -
                have "D1.cones_map (p1  f) π1 = ?χ1'"
                proof
                  fix j
                  show "D1.cones_map (p1  f) π1 j = ?χ1' j"
                    using f p1 π1.cone_axioms χ' π.cone_axioms comp_assoc assms(4) seqI'
                    apply auto
                    by auto
                qed
                moreover have "D1.cones_map (p1  f') π1 = ?χ1'"
                proof
                  fix j
                  show "D1.cones_map (p1  f') π1 j = ?χ1' j"
                    using f' p1 π1.cone_axioms π.cone_axioms comp_assoc assms(4) seqI'
                    apply auto
                    by auto
                qed
                moreover have "p1  f = f1"
                  using 2 f1 f_def p0p1.induced_arrowI'(3) by blast
                  ultimately show ?thesis
                using f1 f1' χ1'.cone_axioms π1.is_universal [of a'] by auto
              qed
              ultimately show "f' = f"
                using f f' p0p1.is_universal' [of a']
                by (metis (no_types, lifting) "1" dom_comp in_homE p0p1.is_universal' p1 seqI')
            qed
          qed
        qed
      qed
      show "has_as_product J.comp ?D ?a"
        unfolding has_as_product_def
        using π.product_cone_axioms by auto
    qed

  end

  sublocale cartesian_category  category_with_finite_products
  proof
    obtain t where t: "terminal t" using has_terminal by blast
    { fix n :: nat
      have "I :: nat set. finite I  card I = n  has_products I"
      proof (induct n)
        show "I :: nat set. finite I  card I = 0  has_products I"
        proof -
          fix I :: "nat set"
          assume "finite I  card I = 0"
          hence I: "I = {}" by force
          thus "has_products I"
          proof -
            interpret J: discrete_category I 0
              apply unfold_locales using I by auto
            have "D. discrete_diagram J.comp C D  a. has_as_product J.comp D a"
            proof -
              fix D
              assume D: "discrete_diagram J.comp C D"
              interpret D: discrete_diagram J.comp C D using D by auto
              interpret D: empty_diagram J.comp C D
                 using I J.arr_char by unfold_locales simp
              have "has_as_product J.comp D t"
                using t D.has_as_limit_iff_terminal has_as_product_def product_cone_def
                      J.category_axioms category_axioms D.discrete_diagram_axioms
                by metis
              thus "a. has_as_product J.comp D a" by blast
            qed
            moreover have "I  UNIV"
              using I by blast
            ultimately show ?thesis
              using I has_products_def
              by (metis category_with_terminal_object.has_terminal discrete_diagram.product_coneI
                  discrete_diagram_def empty_diagram.has_as_limit_iff_terminal empty_diagram.intro
                  empty_diagram_axioms.intro empty_iff has_as_product_def
                  is_category_with_terminal_object mem_Collect_eq)
          qed
        qed
        show "n I :: nat set.
                 (I :: nat set. finite I  card I = n  has_products I);
                  finite I  card I = Suc n 
                     has_products I"
        proof -
          fix n :: nat
          fix I :: "nat set"
          assume IH: "I :: nat set. finite I  card I = n  has_products I"
          assume I: "finite I  card I = Suc n"
          show "has_products I"
          proof -
            have "card I = 1  has_products I"
              using I has_unary_products by blast
            moreover have "card I  1  has_products I"
            proof -
              assume "card I  1"
              hence cardI: "card I > 1" using I by simp
              obtain i where i: "i  I" using cardI by fastforce
              let ?I0 = "{i}" and ?I1 = "I - {i}"
              have 1: "I = ?I0  ?I1  ?I0  ?I1 = {}  card ?I0 = 1  card ?I1 = n"
                using i I cardI by auto
              show "has_products I"
              proof (unfold has_products_def, intro conjI allI impI)
                show "I  UNIV"
                  using I by auto
                fix J D
                assume D: "discrete_diagram J C D  Collect (partial_magma.arr J) = I"
                interpret D: discrete_diagram J C D
                  using D by simp
                have Null: "D.J.null  ?I0  D.J.null  ?I1"
                  using D D.J.not_arr_null i by blast
                interpret J0: discrete_category ?I0 D.J.null
                  using 1 Null D by unfold_locales auto
                interpret J1: discrete_category ?I1 D.J.null
                  using Null by unfold_locales auto
                interpret J0uJ1: discrete_category ‹Collect J0.arr  Collect J1.arr› J0.null
                  using Null 1 J0.null_char J1.null_char by unfold_locales auto
                interpret D0: discrete_diagram_from_map ?I0 C D D.J.null
                  using 1 J0.ide_char D.preserves_ide D D.is_discrete i by unfold_locales auto
                interpret D1: discrete_diagram_from_map ?I1 C D D.J.null
                  using 1 J1.ide_char D.preserves_ide D D.is_discrete i by unfold_locales auto
                obtain a0 where a0: "has_as_product J0.comp D0.map a0"
                  using 1 has_unary_products [of ?I0] has_products_def [of ?I0]
                        D0.discrete_diagram_axioms
                  by fastforce
                obtain a1 where a1: "has_as_product J1.comp D1.map a1"
                  using 1 I IH [of ?I1] has_products_def [of ?I1] D1.discrete_diagram_axioms
                  by blast
                have 2: "p0 p1. has_as_binary_product a0 a1 p0 p1"
                proof -
                  have "ide a0  ide a1"
                    using a0 a1 product_is_ide by auto
                  thus ?thesis
                     using a0 a1 has_binary_products has_binary_products_def by simp
                qed
                obtain p0 p1 where a: "has_as_binary_product a0 a1 p0 p1"
                  using 2 by auto
                let ?a = "dom p0"
                have "has_as_product J D ?a"
                proof -
                  have "D = (λj. if j  Collect J0.arr then D0.map j
                                 else if j  Collect J1.arr then D1.map j
                                 else null)"
                  proof
                    fix j
                    show "D j = (if j  Collect J0.arr then D0.map j
                                 else if j  Collect J1.arr then D1.map j
                                 else null)"
                      using 1 D0.map_def D1.map_def D.is_extensional D J0.arr_char J1.arr_char
                      by auto
                  qed
                  moreover have "J = J0uJ1.comp"
                  proof -
                    have "j j'. J j j' = J0uJ1.comp j j'"
                    proof -
                      fix j j'
                      show "J j j' = J0uJ1.comp j j'"
                        using D J0uJ1.arr_char J0.arr_char J1.arr_char D.is_discrete i
                        apply (cases "j  ?I0", cases "j'  ?I0")
                          apply simp_all
                          apply auto[1]
                         apply (metis D.J.comp_arr_ide D.J.comp_ide_arr D.J.ext D.J.seqE
                            D.is_discrete J0.null_char J0uJ1.null_char)
                        by (metis D.J.comp_arr_ide D.J.comp_ide_arr D.J.comp_ide_self
                            D.J.ext D.J.seqE D.is_discrete J0.null_char J0uJ1.null_char
                            mem_Collect_eq)
                    qed
                    thus ?thesis by blast
                  qed
                  moreover have "Collect J0.arr  Collect J1.arr = {}"
                    by auto
                  moreover have "J0.null = J1.null"
                    using J0.null_char J1.null_char by simp
                  ultimately show "has_as_product J D ?a"
                    using binary_product_of_products_is_product
                            [of J0.comp D0.map a0 J1.comp D1.map a1 p0 p1]
                          J0.arr_char J1.arr_char
                          1 a0 a1 a
                    by simp
                qed
                thus "a. has_as_product J D a" by blast
              qed
            qed
            ultimately show "has_products I" by blast
          qed
        qed
      qed
    }
    hence 1: "n I :: nat set. finite I  card I = n  has_products I" by simp
    thus "I :: nat set. finite I  has_products I" by blast
  qed

  proposition (in cartesian_category) is_category_with_finite_products:
  shows "category_with_finite_products C"
    ..

end

Theory CategoryWithPullbacks

(*  Title:       CategoryWithPullbacks
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2019
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Category with Pullbacks"

theory CategoryWithPullbacks
imports Limit
begin

text ‹
  \sloppypar
  In this chapter, we give a traditional definition of pullbacks in a category as
  limits of cospan diagrams and we define a locale category_with_pullbacks› that
  is satisfied by categories in which every cospan diagram has a limit.
  These definitions build on the general definition of limit that we gave in
  @{theory Category3.Limit}.  We then define a locale elementary_category_with_pullbacks›
  that axiomatizes categories equipped with chosen functions that assign to each cospan
  a corresponding span of ``projections'', which enjoy the familiar universal property
  of a pullback.  After developing consequences of the axioms, we prove that the two
  locales are in agreement, in the sense that every interpretation of
  category_with_pullbacks› extends to an interpretation of
  elementary_category_with_pullbacks›, and conversely, the underlying category of
  an interpretation of elementary_category_with_pullbacks› always yields an interpretation
  of category_with_pullbacks›.
›

  section "Commutative Squares"

  context category
  begin

    text ‹
      The following provides some useful technology for working with commutative squares.
    ›

    definition commutative_square
    where "commutative_square f g h k  cospan f g  span h k  dom f = cod h  f  h = g  k"

    lemma commutative_squareI [intro, simp]:
    assumes "cospan f g" and "span h k" and "dom f = cod h" and "f  h = g  k"
    shows "commutative_square f g h k"
      using assms commutative_square_def by auto

    lemma commutative_squareE [elim]:
    assumes "commutative_square f g h k"
    and " arr f; arr g; arr h; arr k; cod f = cod g; dom h = dom k; dom f = cod h;
           dom g = cod k; f  h = g  k   T"
    shows T
      using assms commutative_square_def
      by (metis (mono_tags, lifting) seqE seqI)

    lemma commutative_square_comp_arr:
    assumes "commutative_square f g h k" and "seq h l"
    shows "commutative_square f g (h  l) (k  l)"
      using assms
      apply (elim commutative_squareE, intro commutative_squareI, auto)
      using comp_assoc by metis

    lemma arr_comp_commutative_square:
    assumes "commutative_square f g h k" and "seq l f"
    shows "commutative_square (l  f) (l  g) h k"
      using assms comp_assoc
      by (elim commutative_squareE, intro commutative_squareI, auto)

  end

  section "Cospan Diagrams"

  (* TODO: Rework the ugly development of equalizers into this form. *)

  text ‹
    The ``shape'' of a cospan diagram is a category having two non-identity arrows
    with distinct domains and a common codomain.
  ›

  locale cospan_shape
  begin

    datatype Arr = Null | AA | BB | TT | AT | BT

    fun comp
    where "comp AA AA = AA"
        | "comp AT AA = AT"
        | "comp TT AT = AT"
        | "comp BB BB = BB"
        | "comp BT BB = BT"
        | "comp TT BT = BT"
        | "comp TT TT = TT"
        | "comp _ _ = Null"

    interpretation partial_magma comp
    proof
      show "∃!n. f. comp n f = n  comp f n = n"
      proof
        show "f. comp Null f = Null  comp f Null = Null" by simp
        show "n. f. comp n f = n  comp f n = n  n = Null"
          by (metis comp.simps(8))
      qed
    qed

    lemma null_char:
    shows "null = Null"
    proof -
      have "f. comp Null f = Null  comp f Null = Null" by simp
      thus ?thesis
        using null_def ex_un_null theI [of "λn. f. comp n f = n  comp f n = n"]
        by (metis partial_magma.comp_null(2) partial_magma_axioms)
    qed

    lemma ide_char:
    shows "ide f  f = AA  f = BB  f = TT"
    proof
      show "ide f  f = AA  f = BB  f = TT"
        using ide_def null_char by (cases f, simp_all)
      show "f = AA  f = BB  f = TT  ide f"
      proof -
        have 1: "f g. f = AA  f = BB  f = TT 
                       comp f f  Null 
                       (comp g f  Null  comp g f = g) 
                       (comp f g  Null  comp f g = g)"
        proof -
          fix f g
          show "f = AA  f = BB  f = TT 
                  comp f f  Null 
                  (comp g f  Null  comp g f = g) 
                  (comp f g  Null  comp f g = g)"
            by (cases f; cases g, auto)
        qed
        assume f: "f = AA  f = BB  f = TT"
        show "ide f"
          using f 1 ide_def null_char by simp
      qed
    qed

    fun Dom
    where "Dom AA = AA"
        | "Dom BB = BB"
        | "Dom TT = TT"
        | "Dom AT = AA"
        | "Dom BT = BB"
        | "Dom _ = Null"

    fun Cod
    where "Cod AA = AA"
        | "Cod BB = BB"
        | "Cod TT = TT"
        | "Cod AT = TT"
        | "Cod BT = TT"
        | "Cod _ = Null"

    lemma domains_char':
    shows "domains f = (if f = Null then {} else {Dom f})"
      using domains_def ide_char null_char
      by (cases f, auto)

    lemma codomains_char':
    shows "codomains f = (if f = Null then {} else {Cod f})"
      using codomains_def ide_char null_char
      by (cases f, auto)

    lemma arr_char:
    shows "arr f  f  Null"
      using arr_def domains_char' codomains_char' by simp

    lemma seq_char:
    shows "seq g f  (f = AA  (g = AA  g = AT)) 
                       (f = BB  (g = BB  g = BT)) 
                       (f = AT  g = TT) 
                       (f = BT  g = TT) 
                       (f = TT  g = TT)"
      using arr_char null_char
      by (cases f; cases g, simp_all)

    interpretation category comp
    proof
      fix f g h
      show "comp g f  null  seq g f"
        using null_char arr_char seq_char by simp
      show "domains f  {}  codomains f  {}"
        using domains_char' codomains_char' by auto
      show "seq h g  seq (comp h g) f  seq g f"
        using seq_char arr_char
        by (cases g; cases h; simp_all)
      show "seq h (comp g f)  seq g f  seq h g"
        using seq_char arr_char
        by (cases f; cases g; simp_all)
      show "seq g f  seq h g  seq (comp h g) f"
        using seq_char arr_char
        by (cases f; simp_all; cases g; simp_all; cases h; auto)
      show "seq g f  seq h g  comp (comp h g) f = comp h (comp g f)"
       using seq_char
       by (cases f; simp_all; cases g; simp_all; cases h; auto)
    qed

    lemma is_category:
    shows "category comp"
      ..

    lemma dom_char:
    shows "dom = Dom"
      using dom_def domains_char domains_char' null_char by fastforce

    lemma cod_char:
    shows "cod = Cod"
      using cod_def codomains_char codomains_char' null_char by fastforce

  end

  sublocale cospan_shape  category comp
    using is_category by auto

  locale cospan_diagram =
    J: cospan_shape +
    C: category C
  for C :: "'c comp"      (infixr "" 55)
  and f0 :: 'c
  and f1 :: 'c +
  assumes is_cospan: "C.cospan f0 f1"
  begin

    no_notation J.comp   (infixr "" 55)
    notation J.comp      (infixr "J" 55)

    fun map
    where "map J.AA = C.dom f0"
        | "map J.BB = C.dom f1"
        | "map J.TT = C.cod f0"
        | "map J.AT = f0"
        | "map J.BT = f1"
        | "map _ = C.null"

  end

  sublocale cospan_diagram  diagram J.comp C map
  proof
    show "f. ¬ J.arr f  map f = C.null"
      using J.arr_char by simp
    fix f
    assume f: "J.arr f"
    show "C.arr (map f)"
      using f J.arr_char is_cospan by (cases f, simp_all)
    show "C.dom (map f) = map (J.dom f)"
      using f J.arr_char J.dom_char is_cospan by (cases f, simp_all)
    show "C.cod (map f) = map (J.cod f)"
      using f J.arr_char J.cod_char is_cospan by (cases f, simp_all)
    next
    fix f g
    assume fg: "J.seq g f"
    show "map (g J f) = map g  map f"
      using fg J.seq_char J.null_char J.not_arr_null is_cospan
      apply (cases f; cases g, simp_all)
      using C.comp_arr_dom C.comp_cod_arr by auto
  qed

  section "Category with Pullbacks"

  text ‹
    A \emph{pullback} in a category @{term C} is a limit of a cospan diagram in @{term C}.
  ›

  context cospan_diagram
  begin

    definition mkCone
    where "mkCone p0 p1  λj. if j = J.AA then p0
                               else if j = J.BB then p1
                               else if j = J.AT then f0  p0
                               else if j = J.BT then f1  p1
                               else if j = J.TT then f0  p0
                               else C.null"

    abbreviation is_rendered_commutative_by
    where "is_rendered_commutative_by p0 p1  C.seq f0 p0  f0  p0 = f1  p1"

    abbreviation has_as_pullback
    where "has_as_pullback p0 p1  limit_cone (C.dom p0) (mkCone p0 p1)"

    lemma cone_mkCone:
    assumes "is_rendered_commutative_by p0 p1"
    shows "cone (C.dom p0) (mkCone p0 p1)"
    proof -
      interpret E: constant_functor J.comp C ‹C.dom p0
        apply unfold_locales using assms by auto
      show "cone (C.dom p0) (mkCone p0 p1)"
      proof
        fix f
        show "¬ J.arr f  mkCone p0 p1 f = C.null"
          using mkCone_def J.arr_char by simp
        assume f: "J.arr f"
        show "C.dom (mkCone p0 p1 f) = E.map (J.dom f)"
          using assms f mkCone_def J.arr_char J.dom_char
          apply (cases f, simp_all)
          by (metis C.dom_comp)+
        show "C.cod (mkCone p0 p1 f) = map (J.cod f)"
          using assms f mkCone_def J.arr_char J.cod_char is_cospan
          by (cases f, auto)
        show "map f  mkCone p0 p1 (J.dom f) = mkCone p0 p1 f"
          using assms f mkCone_def J.arr_char J.dom_char C.comp_ide_arr is_cospan
          by (cases f, auto)
        show "mkCone p0 p1 (J.cod f)  E.map f = mkCone p0 p1 f"
          using assms f mkCone_def J.arr_char J.cod_char C.comp_arr_dom
          apply (cases f, auto)
             apply (metis C.dom_comp C.seqE)
          by (metis C.dom_comp)+
      qed
    qed

    lemma is_rendered_commutative_by_cone:
    assumes "cone a χ"
    shows "is_rendered_commutative_by (χ J.AA) (χ J.BB)"
    proof -
      interpret χ: cone J.comp C map a χ
        using assms by auto
      show ?thesis
      proof
        show "C.seq f0 (χ J.AA)"
          by (metis C.seqI J.cod_char J.seq_char χ.preserves_cod χ.preserves_reflects_arr
              J.seqE is_cospan J.Cod.simps(1) map.simps(1))
        show "f0  χ J.AA = f1  χ J.BB"
          by (metis J.cod_char J.dom_char χ.A.map_simp χ.naturality
              J.Cod.simps(4-5) J.Dom.simps(4-5) J.comp.simps(2,5) J.seq_char map.simps(4-5))
      qed
    qed

    lemma mkCone_cone:
    assumes "cone a χ"
    shows "mkCone (χ J.AA) (χ J.BB) = χ"
    proof -
      interpret χ: cone J.comp C map a χ
        using assms by auto
      have 1: "is_rendered_commutative_by (χ J.AA) (χ J.BB)"
        using assms is_rendered_commutative_by_cone by blast
      interpret mkCone_χ: cone J.comp C map ‹C.dom (χ J.AA) ‹mkCone (χ J.AA) (χ J.BB)
        using assms cone_mkCone 1 by auto
      show ?thesis
      proof -
        have "j. j = J.AA  mkCone (χ J.AA) (χ J.BB) j = χ j"
          using mkCone_def χ.is_extensional by simp
        moreover have "j. j = J.BB  mkCone (χ J.AA) (χ J.BB) j = χ j"
          using mkCone_def χ.is_extensional by simp
        moreover have "j. j = J.TT  mkCone (χ J.AA) (χ J.BB) j = χ j"
          using 1 mkCone_def χ.is_extensional χ.A.map_simp χ.preserves_comp_1
                cospan_shape.seq_char χ.is_natural_2
          apply simp
          by (metis J.seqE J.comp.simps(5) map.simps(5))
        ultimately have "j. J.ide j  mkCone (χ J.AA) (χ J.BB) j = χ j"
          using J.ide_char by auto
        thus "mkCone (χ J.AA) (χ J.BB) = χ"
          using mkCone_def NaturalTransformation.eqI [of J.comp C]
                χ.natural_transformation_axioms mkCone_χ.natural_transformation_axioms
                J.ide_char
          by simp
      qed
    qed

  end

  locale pullback_cone =
    J: cospan_shape +
    C: category C +
    D: cospan_diagram C f0 f1 +
    limit_cone J.comp C D.map ‹C.dom p0 ‹D.mkCone p0 p1
  for C :: "'c comp"      (infixr "" 55)
  and f0 :: 'c
  and f1 :: 'c
  and p0 :: 'c
  and p1 :: 'c
  begin

    (* TODO: Equalizer should be simplifiable in the same way. *)
    lemma renders_commutative:
    shows "D.is_rendered_commutative_by p0 p1"
      using D.mkCone_def D.cospan_diagram_axioms cone_axioms
            cospan_diagram.is_rendered_commutative_by_cone
      by fastforce

    lemma is_universal':
    assumes "D.is_rendered_commutative_by p0' p1'"
    shows "∃!h. «h : C.dom p0'  C.dom p0»  p0  h = p0'  p1  h = p1'"
    proof -
      have "D.cone (C.dom p0') (D.mkCone p0' p1')"
        using assms D.cone_mkCone by blast
      hence 1: "∃!h. «h : C.dom p0'  C.dom p0» 
                     D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
        using is_universal by simp
      have 2: "h. «h : C.dom p0'  C.dom p0» 
                    D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' 
                    p0  h = p0'  p1  h = p1'"
      proof -
        fix h
        assume h: "«h : C.dom p0'  C.dom p0»"
        show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1' 
              p0  h = p0'  p1  h = p1'"
        proof
          assume 3: "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
          show "p0  h = p0'  p1  h = p1'"
          proof
            show "p0  h = p0'"
            proof -
              have "p0' = D.mkCone p0' p1' J.AA"
                using D.mkCone_def J.arr_char by simp
              also have "... = D.cones_map h (D.mkCone p0 p1) J.AA"
                using 3 by simp
              also have "... = p0  h"
                using h D.mkCone_def J.arr_char cone_χ by auto
              finally show ?thesis by auto
            qed
            show "p1  h = p1'"
            proof -
              have "p1' = D.mkCone p0' p1' J.BB"
                using D.mkCone_def J.arr_char by simp
              also have "... = D.cones_map h (D.mkCone p0 p1) J.BB"
                using 3 by simp
              also have "... = p1  h"
                using h D.mkCone_def J.arr_char cone_χ by auto
              finally show ?thesis by auto
            qed
          qed
          next
          assume 4: "p0  h = p0'  p1  h = p1'"
          show "D.cones_map h (D.mkCone p0 p1) = D.mkCone p0' p1'"
          proof
            fix j
            have "¬ J.arr j  D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
              using h cone_axioms D.mkCone_def J.arr_char by auto
            moreover have "J.arr j 
                           D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
              using assms h 4 cone_χ D.mkCone_def J.arr_char renders_commutative
                    C.comp_assoc
              by fastforce
            ultimately show "D.cones_map h (D.mkCone p0 p1) j = D.mkCone p0' p1' j"
              using J.arr_char J.Dom.cases by blast
          qed
        qed
      qed
      thus ?thesis using 1 by blast
    qed

    lemma induced_arrowI':
    assumes "D.is_rendered_commutative_by p0' p1'"
    shows "«induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0'  C.dom p0»"
    and "p0  induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
    and "p1  induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
    proof -
      interpret A': constant_functor J.comp C ‹C.dom p0'
        using assms by (unfold_locales, auto)
      have cone: "D.cone (C.dom p0') (D.mkCone p0' p1')"
        using assms D.cone_mkCone [of p0' p1'] by blast
      show 1: "p0  induced_arrow (C.dom p0') (D.mkCone p0' p1') = p0'"
      proof -
        have "p0  induced_arrow (C.dom p0') (D.mkCone p0' p1') =
                D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                            (D.mkCone p0 p1) J.AA"
          using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by force
        also have "... = p0'"
        proof -
          have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                            (D.mkCone p0 p1) =
                D.mkCone p0' p1'"
            using cone induced_arrowI by blast
          thus ?thesis
            using J.arr_char D.mkCone_def by simp
        qed
        finally show ?thesis by auto
      qed
      show 2: "p1  induced_arrow (C.dom p1') (D.mkCone p0' p1') = p1'"
      proof -
        have "p1  induced_arrow (C.dom p1') (D.mkCone p0' p1') =
              D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                          (D.mkCone p0 p1) J.BB"
        proof -
          have "C.dom p0' = C.dom p1'"
            using assms by (metis C.dom_comp)
          thus ?thesis
            using cone induced_arrowI(1) D.mkCone_def J.arr_char cone_χ by force
        qed
        also have "... = p1'"
        proof -
          have "D.cones_map (induced_arrow (C.dom p0') (D.mkCone p0' p1'))
                            (D.mkCone p0 p1) =
                D.mkCone p0' p1'"
            using cone induced_arrowI by blast
          thus ?thesis
            using J.arr_char D.mkCone_def by simp
        qed
        finally show ?thesis by auto
      qed
      show "«induced_arrow (C.dom p0') (D.mkCone p0' p1') : C.dom p0'  C.dom p0»"
        using 1 cone induced_arrowI by simp
    qed

  end

  context category
  begin

    definition has_as_pullback
    where "has_as_pullback f0 f1 p0 p1 
           cospan f0 f1  cospan_diagram.has_as_pullback C f0 f1 p0 p1"

    definition has_pullbacks
    where "has_pullbacks = (f0 f1. cospan f0 f1  (p0 p1. has_as_pullback f0 f1 p0 p1))"

  end

  locale category_with_pullbacks =
    category +
  assumes has_pullbacks: has_pullbacks

  section "Elementary Category with Pullbacks"

  text ‹
    An \emph{elementary category with pullbacks} is a category equipped with a specific
    way of mapping each cospan to a span such that the resulting square commutes and
    such that the span is universal for that property.  It is useful to assume that the
    functions, mapping a cospan to the two projections of the pullback, are extensional;
    that is, they yield @{term null} when applied to arguments that do not form a cospan.
  ›

  locale elementary_category_with_pullbacks =
    category C
  for C :: "'a comp"                              (infixr "" 55)
  and prj0 :: "'a  'a  'a"                    ("𝗉0[_, _]")
  and prj1 :: "'a  'a  'a"                    ("𝗉1[_, _]") +
  assumes prj0_ext: "¬ cospan f g  𝗉0[f, g] = null"
  and prj1_ext: "¬ cospan f g  𝗉1[f, g] = null"
  and pullback_commutes [intro]: "cospan f g  commutative_square f g 𝗉1[f, g] 𝗉0[f, g]"
  and universal: "commutative_square f g h k  ∃!l. 𝗉1[f, g]  l = h  𝗉0[f, g]  l = k"
  begin

    lemma pullback_commutes':
    assumes "cospan f g"
    shows "f  𝗉1[f, g] = g  𝗉0[f, g]"
      using assms commutative_square_def by blast

    lemma prj0_in_hom':
    assumes "cospan f g"
    shows "«𝗉0[f, g] : dom 𝗉0[f, g]  dom g»"
      using assms pullback_commutes
      by (metis category.commutative_squareE category_axioms in_homI)

    lemma prj1_in_hom':
    assumes "cospan f g"
    shows "«𝗉1[f, g] : dom 𝗉0[f, g]  dom f»"
      using assms pullback_commutes
      by (metis category.commutative_squareE category_axioms in_homI)

    text ‹
      The following gives us a notation for the common domain of the two projections
      of a pullback.
    ›

    definition pbdom        (infix "↓↓" 51)
    where "f ↓↓ g  dom 𝗉0[f, g]"

    lemma pbdom_in_hom [intro]:
    assumes "cospan f g"
    shows "«f ↓↓ g : f ↓↓ g  f ↓↓ g»"
      unfolding pbdom_def
      using assms prj0_in_hom'
      by (metis arr_dom_iff_arr arr_iff_in_hom cod_dom dom_dom in_homE)

    lemma ide_pbdom [simp]:
    assumes "cospan f g"
    shows "ide (f ↓↓ g)"
      using assms ide_in_hom by auto[1]

    lemma prj0_in_hom [intro, simp]:
    assumes "cospan f g" and "a = f ↓↓ g" and "b = dom g"
    shows "«𝗉0[f, g] : a  b»"
      unfolding pbdom_def
      using assms prj0_in_hom' by (simp add: pbdom_def)

    lemma prj1_in_hom [intro, simp]:
    assumes "cospan f g" and "a = f ↓↓ g" and "b = dom f"
    shows "«𝗉1[f, g] : a  b»"
      unfolding pbdom_def
      using assms prj1_in_hom' by (simp add: pbdom_def)

    lemma prj0_simps [simp]:
    assumes "cospan f g"
    shows "arr 𝗉0[f, g]" and "dom 𝗉0[f, g] = f ↓↓ g" and "cod 𝗉0[f, g] = dom g"
      using assms prj0_in_hom by (blast, blast, blast)

    lemma prj0_simps_arr [iff]:
    shows "arr 𝗉0[f, g]  cospan f g"
    proof
      show "cospan f g  arr 𝗉0[f, g]"
        using prj0_in_hom by auto
      show "arr 𝗉0[f, g]  cospan f g"
        using prj0_ext not_arr_null by metis
    qed

    lemma prj1_simps [simp]:
    assumes "cospan f g"
    shows "arr 𝗉1[f, g]" and "dom 𝗉1[f, g] = f ↓↓ g" and "cod 𝗉1[f, g] = dom f"
      using assms prj1_in_hom by (blast, blast, blast)

    lemma prj1_simps_arr [iff]:
    shows "arr 𝗉1[f, g]  cospan f g"
    proof
      show "cospan f g  arr 𝗉1[f, g]"
        using prj1_in_hom by auto
      show "arr 𝗉1[f, g]  cospan f g"
        using prj1_ext not_arr_null by metis
    qed

    lemma span_prj:
    assumes "cospan f g"
    shows "span 𝗉0[f, g] 𝗉1[f, g]"
      using assms by simp

    text ‹
      We introduce a notation for tupling, which produces the induced arrow into a pullback.
      In our notation, the ``$0$-side'', which we regard as the input, occurs on the right,
      and the ``$1$-side'', which we regard as the output, occurs on the left.
    ›

    definition tuple         ("_ _, _ _")
    where "h f, g k  if commutative_square f g h k then
                           THE l. 𝗉0[f, g]  l = k  𝗉1[f, g]  l = h
                         else null"

    lemma tuple_in_hom [intro]:
    assumes "commutative_square f g h k"
    shows "«h f, g k : dom h  f ↓↓ g»"
    proof
      have 1: "𝗉0[f, g]  h f, g k = k  𝗉1[f, g]  h f, g k = h"
        unfolding tuple_def
        using assms universal theI [of "λl. 𝗉0[f, g]  l = k  𝗉1[f, g]  l = h"]
        apply simp
        by meson
      show "arr h f, g k"
        using assms 1
        apply (elim commutative_squareE)
        by (metis (no_types, lifting) seqE)
      show "dom h f, g k = dom h"
        using assms 1
        apply (elim commutative_squareE)
        by (metis (no_types, lifting) dom_comp)
      show "cod h f, g k = f ↓↓ g"
        unfolding pbdom_def
        using assms 1
        apply (elim commutative_squareE)
        by (metis seqE)
    qed

    lemma tuple_is_extensional:
    assumes "¬ commutative_square f g h k"
    shows "h f, g k = null"
      unfolding tuple_def
      using assms by simp

    lemma tuple_simps [simp]:
    assumes "commutative_square f g h k"
    shows "arr h f, g k" and "dom h f, g k = dom h" and "cod h f, g k = f ↓↓ g"
      using assms tuple_in_hom apply blast
      using assms tuple_in_hom apply blast
      using assms tuple_in_hom by blast

    lemma prj_tuple [simp]:
    assumes "commutative_square f g h k"
    shows "𝗉0[f, g]  h f, g k = k" and "𝗉1[f, g]  h f, g k = h"
    proof -
      have 1: "𝗉0[f, g]  h f, g k = k  𝗉1[f, g]  h f, g k = h"
        unfolding tuple_def
        using assms universal theI [of "λl. 𝗉0[f, g]  l = k  𝗉1[f, g]  l = h"]
        apply simp
        by meson
      show "𝗉0[f, g]  h f, g k = k" using 1 by simp
      show "𝗉1[f, g]  h f, g k = h" using 1 by simp
    qed

    lemma tuple_prj:
    assumes "cospan f g" and "seq 𝗉1[f, g] h"
    shows "𝗉1[f, g]  h f, g 𝗉0[f, g]  h = h"
    proof -
      have 1: "commutative_square f g (𝗉1[f, g]  h) (𝗉0[f, g]  h)"
        using assms pullback_commutes
        by (simp add: commutative_square_comp_arr)
      have "𝗉0[f, g]  𝗉1[f, g]  h f, g 𝗉0[f, g]  h = 𝗉0[f, g]  h"
        using assms 1 by simp
      moreover have "𝗉1[f, g]  𝗉1[f, g]  h f, g 𝗉0[f, g]  h = 𝗉1[f, g]  h"
        using assms 1 by simp
      ultimately show ?thesis
        unfolding tuple_def
        using assms 1 universal [of f g "𝗉1[f, g]  h" "𝗉0[f, g]  h"]
              theI_unique [of "λl. 𝗉0[f, g]  l = 𝗉0[f, g]  h  𝗉1[f, g]  l = 𝗉1[f, g]  h" h]
        by auto
    qed

    lemma tuple_prj_spc [simp]:
    assumes "cospan f g"
    shows "𝗉1[f, g] f, g 𝗉0[f, g] = f ↓↓ g"
    proof -
      have "𝗉1[f, g] f, g 𝗉0[f, g] = 𝗉1[f, g]  (f ↓↓ g) f, g 𝗉0[f, g]  (f ↓↓ g)"
        using assms comp_arr_dom by simp
      thus ?thesis
        using assms tuple_prj by simp
    qed

    lemma prj_joint_monic:
    assumes "cospan f g" and "seq 𝗉1[f, g] h" and "seq 𝗉1[f, g] h'"
    and "𝗉0[f, g]  h = 𝗉0[f, g]  h'" and "𝗉1[f, g]  h = 𝗉1[f, g]  h'"
    shows "h = h'"
    proof -
      have "h = 𝗉1[f, g]  h f, g 𝗉0[f, g]  h"
        using assms tuple_prj [of f g h] by simp
      also have "... = 𝗉1[f, g]  h' f, g 𝗉0[f, g]  h'"
        using assms by simp
      also have "... = h'"
        using assms tuple_prj [of f g h'] by simp
      finally show ?thesis by blast
    qed

    text ‹
      The pullback of an identity along an arbitrary arrow is an isomorphism.
    ›

    lemma iso_pullback_ide:
    assumes "cospan μ ν" and "ide μ"
    shows "iso 𝗉0[μ, ν]"
    proof -
      have "inverse_arrows 𝗉0[μ, ν] ν μ, ν dom ν"
      proof
        show 1: "ide (𝗉0[μ, ν]  ν μ, ν dom ν)"
          using assms comp_arr_dom comp_cod_arr prj_tuple(1) by simp
        show "ide (ν μ, ν dom ν  𝗉0[μ, ν])"
        proof -
          have "ν μ, ν dom ν  𝗉0[μ, ν] = (μ ↓↓ ν)"
          proof -
            have "𝗉0[μ, ν]  ν μ, ν dom ν  𝗉0[μ, ν] = 𝗉0[μ, ν]  (μ ↓↓ ν)"
            proof -
              have "𝗉0[μ, ν]  ν μ, ν dom ν  𝗉0[μ, ν] = (𝗉0[μ, ν]  ν μ, ν dom ν)  𝗉0[μ, ν]"
                using assms 1 comp_reduce by blast
              also have "... = 𝗉0[μ, ν]  (μ ↓↓ ν)"
                using assms prj_tuple(1) pullback_commutes comp_arr_dom comp_cod_arr by simp
              finally show ?thesis by blast
            qed
            moreover have "𝗉1[μ, ν]  ν μ, ν dom ν  𝗉0[μ, ν] = 𝗉1[μ, ν]  (μ ↓↓ ν)"
            proof -
              have "𝗉1[μ, ν]  ν μ, ν dom ν  𝗉0[μ, ν] = (𝗉1[μ, ν]  ν μ, ν dom ν)  𝗉0[μ, ν]"
                using assms(2) comp_assoc by simp
              also have "... = ν  𝗉0[μ, ν]"
                using assms comp_arr_dom comp_cod_arr prj_tuple(2) by fastforce
              also have "... = μ  𝗉1[μ, ν]"
                using assms pullback_commutes commutative_square_def by simp
              also have "... = 𝗉1[μ, ν]  (μ ↓↓ ν)"
                using assms comp_arr_dom comp_cod_arr pullback_commutes commutative_square_def
                by simp
              finally show ?thesis by simp
            qed
            ultimately show ?thesis
              using assms prj0_in_hom prj1_in_hom comp_arr_dom prj1_simps(1-2) prj_joint_monic
              by metis
          qed
          thus ?thesis
            using assms by auto
        qed
      qed
      thus ?thesis by auto
    qed

    lemma comp_tuple_arr:
    assumes "commutative_square f g h k" and "seq h l"
    shows "h f, g k  l = h  l f, g k  l"
    proof -
      have "𝗉0[f, g]  h f, g k  l = 𝗉0[f, g]  h  l f, g k  l"
      proof -
        have "𝗉0[f, g]  h f, g k  l = (𝗉0[f, g]  h f, g k)  l"
          using comp_assoc by simp
        also have "... = 𝗉0[f, g]  h  l f, g k  l"
          using assms commutative_square_comp_arr by auto
        finally show ?thesis by blast
      qed
      moreover have "𝗉1[f, g]  h f, g k  l = 𝗉1[f, g]  h  l f, g k  l"
      proof -
        have "𝗉1[f, g]  h f, g k  l = (𝗉1[f, g]  h f, g k)  l"
          using comp_assoc by simp
        also have "... = 𝗉1[f, g]  h  l f, g k  l"
          using assms commutative_square_comp_arr by auto
        finally show ?thesis by blast
      qed
      moreover have "seq 𝗉1[f, g] (h f, g k  l)"
        using assms tuple_in_hom prj1_in_hom by fastforce
      ultimately show ?thesis
        using assms prj_joint_monic [of f g "h f, g k  l" "h  l f, g k  l"]
        by auto
    qed

    lemma pullback_arr_cod:
    assumes "arr f"
    shows "inverse_arrows 𝗉1[f, cod f] dom f f, cod f f"
    and "inverse_arrows 𝗉0[cod f, f] f cod f, f dom f"
    proof -
      show "inverse_arrows 𝗉1[f, cod f] dom f f, cod f f"
      proof
        show "ide (dom f f, cod f f  𝗉1[f, cod f])"
        proof -
          have "dom f f, cod f f  𝗉1[f, cod f] = f ↓↓ cod f"
          proof -
            have "𝗉0[f, cod f]  dom f f, cod f f  𝗉1[f, cod f] = 𝗉0[f, cod f]  (f ↓↓ cod f)"
            proof -
              have "𝗉0[f, cod f]  dom f f, cod f f  𝗉1[f, cod f] =
                    (𝗉0[f, cod f]  dom f f, cod f f)  𝗉1[f, cod f]"
                using comp_assoc by simp
              also have "... = 𝗉0[f, cod f]  (f ↓↓ cod f)"
                using assms pullback_commutes [of f "cod f"] comp_arr_dom comp_cod_arr
                by auto
              finally show ?thesis by blast
            qed
            moreover
            have "𝗉1[f, cod f]  dom f f, cod f f  𝗉1[f, cod f] = 𝗉1[f, cod f]  (f ↓↓ cod f)"
            proof -
              have "𝗉1[f, cod f]  dom f f, cod f f  𝗉1[f, cod f] =
                    (𝗉1[f, cod f]  dom f f, cod f f)  𝗉1[f, cod f]"
                using assms comp_assoc by presburger
              also have "... = 𝗉1[f, cod f]  (f ↓↓ cod f)"
                using assms comp_arr_dom comp_cod_arr by simp
              finally show ?thesis by blast
            qed
            ultimately show ?thesis
              using assms
                    prj_joint_monic
                      [of f "cod f" "dom f f, cod f f  𝗉1[f, cod f]" "f ↓↓ cod f"]
              by simp
          qed
          thus ?thesis
            using assms arr_cod cod_cod prj1_simps_arr by simp
        qed
        show "ide (𝗉1[f, cod f]  dom f f, cod f f)"
          using assms comp_arr_dom comp_cod_arr by fastforce
      qed
      show "inverse_arrows 𝗉0[cod f, f] f cod f, f dom f"
      proof
        show "ide (𝗉0[cod f, f]  f cod f, f dom f)"
          using assms comp_arr_dom comp_cod_arr by simp
        show "ide (f cod f, f dom f  𝗉0[cod f, f])"
        proof -
          have "f cod f, f dom f  𝗉0[cod f, f] = cod f ↓↓ f"
          proof -
            have "𝗉0[cod f, f]  f cod f, f dom f  𝗉0[cod f, f] = 𝗉0[cod f, f]  (cod f ↓↓ f)"
            proof -
              have "𝗉0[cod f, f]  f cod f, f dom f  𝗉0[cod f, f] =
                    (𝗉0[cod f, f]  f cod f, f dom f)  𝗉0[cod f, f]"
                using comp_assoc by simp
              also have "... = dom f  𝗉0[cod f, f]"
                using assms comp_arr_dom comp_cod_arr by simp
              also have "... = 𝗉0[cod f, f]  (cod f ↓↓ f)"
                using assms comp_arr_dom comp_cod_arr by simp
              finally show ?thesis
                using prj0_in_hom by blast
            qed
            moreover
            have "𝗉1[cod f, f]  f cod f, f dom f  𝗉0[cod f, f] = 𝗉1[cod f, f]  (cod f ↓↓ f)"
            proof -
              have "𝗉1[cod f, f]  f cod f, f dom f  𝗉0[cod f, f] =
                    (𝗉1[cod f, f]  f cod f, f dom f)  𝗉0[cod f, f]"
                using comp_assoc by simp
              also have "... = 𝗉1[cod f, f]  (cod f ↓↓ f)"
                using assms pullback_commutes [of "cod f" f] comp_arr_dom comp_cod_arr
                by auto
              finally show ?thesis by blast
            qed
            ultimately show ?thesis
              using assms prj_joint_monic [of "cod f" f "f cod f, f dom f  𝗉0[cod f, f]"]
              by simp
          qed
          thus ?thesis using assms by simp
        qed
      qed
    qed

    text ‹
      The pullback of a monomorphism along itself is automatically symmetric: the left
      and right projections are equal.
    ›

    lemma pullback_mono_self:
    assumes "mono f"
    shows "𝗉0[f, f] = 𝗉1[f, f]"
    proof -
      have "f  𝗉0[f, f] = f  𝗉1[f, f]"
        using assms pullback_commutes [of f f]
        by (metis commutative_squareE mono_implies_arr)
      thus ?thesis
        using assms monoE [of f "𝗉1[f, f]" "𝗉0[f, f]"]
        by (metis mono_implies_arr prj0_simps(1,3) seqI)
    qed

    lemma pullback_iso_self:
    assumes "iso f"
    shows "𝗉0[f, f] = 𝗉1[f, f]"
      using assms pullback_mono_self iso_is_section section_is_mono by simp

    lemma pullback_ide_self [simp]:
    assumes "ide a"
    shows "𝗉0[a, a] = 𝗉1[a, a]"
      using assms pullback_iso_self ide_is_iso by blast

  end

  section "Agreement between the Definitions"

  text ‹
    It is very easy to write locale assumptions that have unintended consequences
    or that are even inconsistent.  So, to keep ourselves honest, we don't just accept the
    definition of ``elementary category with pullbacks'', but in fact we formally establish
    the sense in which it agrees with our standard definition of ``category with pullbacks'',
    which is given in terms of limit cones.
    This is extra work, but it ensures that we didn't make a mistake.
  ›

  context category_with_pullbacks
  begin

    definition prj1
    where "prj1 f g  if cospan f g then
                         fst (SOME x. cospan_diagram.has_as_pullback C f g (fst x) (snd x))
                       else null"

    definition prj0
    where "prj0 f g  if cospan f g then
                         snd (SOME x. cospan_diagram.has_as_pullback C f g (fst x) (snd x))
                       else null"

    lemma prj_yields_pullback:
    assumes "cospan f g"
    shows "cospan_diagram.has_as_pullback C f g (prj1 f g) (prj0 f g)"
    proof -
      have "x. cospan_diagram.has_as_pullback C f g (fst x) (snd x)"
        using assms has_pullbacks has_pullbacks_def has_as_pullback_def by simp
      thus ?thesis
        using assms has_pullbacks has_pullbacks_def prj0_def prj1_def
              someI_ex [of "λx. cospan_diagram.has_as_pullback C f g (fst x) (snd x)"]
        by simp
    qed

    interpretation elementary_category_with_pullbacks C prj0 prj1
    proof
      show "f g. ¬ cospan f g  prj0 f g = null"
        using prj0_def by auto
      show "f g. ¬ cospan f g  prj1 f g = null"
        using prj1_def by auto
      show "f g. cospan f g  commutative_square f g (prj1 f g) (prj0 f g)"
      proof
        fix f g
        assume fg: "cospan f g"
        show "cospan f g" by fact
        interpret J: cospan_shape .
        interpret D: cospan_diagram C f g
          using fg by (unfold_locales, auto)
        let  = "D.mkCone (prj1 f g) (prj0 f g)"
        interpret χ: limit_cone J.comp C D.map ‹dom (prj1 f g) 
          using fg prj_yields_pullback by auto
        have 1: "prj1 f g =  J.AA  prj0 f g =  J.BB"
          using D.mkCone_def by simp
        show "span (prj1 f g) (prj0 f g)"
        proof -
          have "arr (prj1 f g)  arr (prj0 f g)"
            using 1 J.arr_char J.seq_char
            by (metis J.seqE χ.preserves_reflects_arr)
          moreover have "dom (prj1 f g) = dom (prj0 f g)"
            using 1 D.is_rendered_commutative_by_cone χ.cone_axioms J.seq_char
            by (metis J.cod_eqI J.seqE χ.A.map_simp χ.preserves_dom J.ide_char)
          ultimately show ?thesis by simp
        qed
        show "dom f = cod (prj1 f g)"
          using 1 fg χ.preserves_cod [of J.BB] J.cod_char D.mkCone_def
          by (metis D.map.simps(1) D.preserves_cod J.seqE χ.preserves_cod cod_dom J.seq_char)
        show "f  prj1 f g = g  prj0 f g"
          using 1 fg D.is_rendered_commutative_by_cone χ.cone_axioms by force
      qed
      show "f g h k. commutative_square f g h k  ∃!l. prj1 f g  l = h  prj0 f g  l = k"
      proof -
        fix f g h k
        assume fghk: "commutative_square f g h k"
        interpret J: cospan_shape .
        interpret D: cospan_diagram C f g
          using fghk by (unfold_locales, auto)
        let  = "D.mkCone (prj1 f g) (prj0 f g)"
        interpret χ: limit_cone J.comp C D.map ‹dom (prj1 f g) 
          using fghk prj_yields_pullback by auto
        interpret χ: pullback_cone C f g ‹prj1 f g ‹prj0 f g ..
        have 1: "prj1 f g =  J.AA  prj0 f g =  J.BB"
          using D.mkCone_def by simp
        show "∃!l. prj1 f g  l = h  prj0 f g  l = k"
        proof
          let ?l = "SOME l. prj1 f g  l = h  prj0 f g  l = k"
          show "prj1 f g  ?l = h  prj0 f g  ?l = k"
             using fghk χ.is_universal' χ.renders_commutative
                   someI_ex [of "λl. prj1 f g  l = h  prj0 f g  l = k"]
             by blast
          thus "l. prj1 f g  l = h  prj0 f g  l = k  l = ?l"
            using fghk χ.is_universal' χ.renders_commutative limit_cone_def
            by (metis (no_types, lifting) in_homI seqE commutative_squareE dom_comp seqI)
        qed
      qed
    qed

    proposition extends_to_elementary_category_with_pullbacks:
    shows "elementary_category_with_pullbacks C prj0 prj1"
      ..

  end

  context elementary_category_with_pullbacks
  begin

    interpretation category_with_pullbacks C
    proof
      show "has_pullbacks"
      proof (unfold has_pullbacks_def)
        have "f g. cospan f g  p0 p1. has_as_pullback f g p0 p1"
        proof -
          fix f g
          assume fg: "cospan f g"
          interpret J: cospan_shape .
          interpret D: cospan_diagram C f g
            using fg by (unfold_locales, auto)
          let  = "D.mkCone 𝗉1[f, g] 𝗉0[f, g]"
          interpret χ: cone J.comp C D.map ‹dom 𝗉1[f, g] 
          proof -
            have "D.is_rendered_commutative_by 𝗉1[f, g] 𝗉0[f, g]"
              using fg pullback_commutes' by simp
            thus "cone J.comp C D.map (dom 𝗉1[f, g]) "
              using D.cone_mkCone by auto
          qed
          interpret χ: limit_cone J.comp C D.map ‹dom 𝗉1[f, g] 
          proof
            fix a' χ'
            assume χ': "D.cone a' χ'"
            interpret χ': cone J.comp C D.map a' χ'
              using χ' by simp
            have 1: "commutative_square f g (χ' J.AA) (χ' J.BB)"
              using fg J.ide_char J.cod_char D.is_rendered_commutative_by_cone χ'.cone_axioms
              by auto
            show "∃!h. «h : a'  dom 𝗉1[f, g]» 
                       D.cones_map h (D.mkCone 𝗉1[f, g] 𝗉0[f, g]) = χ'"
            proof
              let ?h = "χ' J.AA f, g χ' J.BB"
              show h': "«?h : a'  dom 𝗉1[f, g]» 
                        D.cones_map ?h (D.mkCone 𝗉1[f, g] 𝗉0[f, g]) = χ'"
              proof
                show h: "«?h : a'  dom 𝗉1[f, g]»"
                  using fg 1 by fastforce
                show "D.cones_map ?h (D.mkCone 𝗉1[f, g] 𝗉0[f, g]) = χ'"
                proof -
                  have "D.mkCone 𝗉1[f, g] 𝗉0[f, g]  D.cones (cod χ' J.AA f, g χ' J.BB)"
                    using fg h D.cone_mkCone D.is_rendered_commutative_by_cone
                          χ.cone_axioms
                    by auto
                  hence 2: "D.cones_map ?h (D.mkCone 𝗉1[f, g] 𝗉0[f, g])  D.cones a'"
                    using fg h D.cones_map_mapsto by blast
                  interpret χ'h: cone J.comp C D.map a'
                                   ‹D.cones_map ?h (D.mkCone 𝗉1[f, g] 𝗉0[f, g])
                    using 2 by simp
                  show ?thesis
                  proof -
                    have "j. J.ide j  D.cones_map ?h (D.mkCone 𝗉1[f, g] 𝗉0[f, g]) j = χ' j"
                    proof -
                      fix j
                      show "J.ide j  D.cones_map ?h (D.mkCone 𝗉1[f, g] 𝗉0[f, g]) j = χ' j"
                        using fg h 1 J.ide_char D.mkCone_def χ.cone_axioms
                        apply (cases j, simp_all)
                        by (metis D.map.simps(4) J.dom_eqI χ'.is_natural_1 χ'.naturality
                            J.seqE χ'.A.map_simp J.comp.simps(3,7) J.seq_char
                            prj_tuple(2) comp_assoc)
                    qed
                    thus ?thesis
                      using NaturalTransformation.eqI
                            χ'.natural_transformation_axioms χ'h.natural_transformation_axioms
                      by blast
                  qed
                qed
              qed
              show "h. «h : a'  dom 𝗉1[f, g]» 
                        D.cones_map h (D.mkCone 𝗉1[f, g] 𝗉0[f, g]) = χ' 
                          h = ?h"
              proof -
                fix h
                assume 2: "«h : a'  dom 𝗉1[f, g]» 
                        D.cones_map h (D.mkCone 𝗉1[f, g] 𝗉0[f, g]) = χ'"
                show "h = ?h"
                proof -
                  have "𝗉0[f, g]  h = 𝗉0[f, g]  ?h  𝗉1[f, g]  h = 𝗉1[f, g]  ?h"
                    using 1 2 fg J.arr_char χ.cone_axioms D.mkCone_def by auto
                  thus ?thesis
                    using fg 2 h' prj_joint_monic by blast
                qed
              qed
            qed
          qed
          show "p0 p1. has_as_pullback f g p0 p1"
            using fg has_as_pullback_def χ.limit_cone_axioms by blast
        qed
        thus "f g. cospan f g  (p0 p1. has_as_pullback f g p0 p1)"
          by simp
      qed
    qed

    proposition is_category_with_pullbacks:
    shows "category_with_pullbacks C"
      ..

  end

  sublocale elementary_category_with_pullbacks  category_with_pullbacks
    using is_category_with_pullbacks by auto

end

Theory CategoryWithFiniteLimits

(*  Title:       CategoryWithFiniteLimits
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2020
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Category with Finite Limits"

theory CategoryWithFiniteLimits
imports CartesianCategory CategoryWithPullbacks
begin

  text‹
    In this chapter we define ``category with finite limits'' and show that such
    categories coincide with those having pullbacks and a terminal object.

    Since we can't quantify over types in HOL, the best we can do at defining the notion
    ``category with finite limits'' is to state it for a fixed choice of type (e.g.~@{typ nat})
    for the arrows of the ``diagram shape''.  However, we then have to go to some
    trouble to show the existence of finite limits for diagram shapes at other types.
  ›

  locale category_with_finite_limits =
    category +
  assumes has_finite_limits:
            " category (J :: nat comp); finite (Collect (partial_magma.arr J)) 
                  has_limits_of_shape J"
  begin

    text‹
      We show that a category with finite limits has pullbacks and a terminal object
      and is therefore also a cartesian category.
    ›

    interpretation category_with_pullbacks C
    proof -
      interpret J: cospan_shape
        by unfold_locales
      have 1: "finite (Collect J.arr)"
      proof -
        have "Collect J.arr = {J.AA, J.BB, J.TT, J.AT, J.BT}"
          using J.arr_char cospan_shape.Dom.cases by auto
        thus ?thesis by simp
      qed
      obtain J' :: "nat comp" where J': "isomorphic_categories J' J.comp"
        using 1 J.finite_imp_ex_iso_nat_comp by blast
      interpret J'J: isomorphic_categories J' J.comp
        using J' by simp
      obtain φ ψ where φψ: "inverse_functors J.comp J' φ ψ"
        using J'J.iso inverse_functors_sym by blast
      interpret φψ: inverse_functors J.comp J' φ ψ
        using φψ by simp
      interpret ψ: invertible_functor J.comp J' ψ
        using φψ.inverse_functors_axioms
        by unfold_locales auto
      show "category_with_pullbacks C"
      proof
        show "has_pullbacks"
        proof (unfold has_pullbacks_def has_as_pullback_def, intro allI impI)
          fix f0 f1
          assume cospan: "cospan f0 f1"
          interpret D: cospan_diagram C f0 f1
            using cospan
            by (simp add: category_axioms cospan_diagram_axioms_def cospan_diagram_def)
          have 2: "has_limits_of_shape J.comp"
            using 1 bij_betw_finite J'J.A.category_axioms has_finite_limits ψ.bij_betw_arr_sets
                  has_limits_preserved_by_isomorphism J'J.isomorphic_categories_axioms
            by blast
          obtain a χ where χ: "limit_cone J.comp C D.map a χ"
            using 2 D.diagram_axioms has_limits_of_shape_def by blast
          interpret χ: limit_cone J.comp C D.map a χ
            using χ by simp
          have "D.map = cospan_diagram.map C f0 f1" by simp
          moreover have "a = dom (χ J.AA)"
            using J.arr_char χ.component_in_hom by force
          moreover have "χ = cospan_diagram.mkCone (⋅) f0 f1 (χ J.AA) (χ J.BB)"
            using D.mkCone_cone χ.cone_axioms by auto
          ultimately have "limit_cone (⋅J) (⋅)
                             (cospan_diagram.map (⋅) f0 f1) (dom (χ J.AA))
                             (cospan_diagram.mkCone (⋅) f0 f1 (χ J.AA) (χ J.BB))"
            using χ.limit_cone_axioms by simp
          thus "p0 p1. cospan f0 f1 
                        limit_cone (⋅J) (⋅)
                          (cospan_diagram.map (⋅) f0 f1) (dom p0)
                          (cospan_diagram.mkCone (⋅) f0 f1 p0 p1)"
            using cospan by auto
        qed
      qed
    qed

    lemma is_category_with_pullbacks:
    shows "category_with_pullbacks C"
      ..

    sublocale category_with_pullbacks C ..

    interpretation category_with_terminal_object C
    proof
      show "a. terminal a"
      proof -
        interpret J: discrete_category {} :: nat set› 0
          by unfold_locales simp
        have 1: "has_limits_of_shape J.comp"
          using has_finite_limits
          by (metis Collect_empty_eq J.arr_char J.is_category empty_iff finite.emptyI)
        interpret D: diagram J.comp C λ_. null›
          by unfold_locales auto
        obtain t τ where τ: "D.limit_cone t τ"
          using 1 D.diagram_axioms has_limits_of_shape_def by blast
        interpret τ: limit_cone J.comp C λ_. null› t τ
          using τ by simp
        have "terminal t"
        proof
          show "ide t"
            using τ.ide_apex by simp
          fix a
          assume a: "ide a"
          show "∃!f. «f : a  t»"
          proof -
            interpret a: constant_functor J.comp C a
              using a by unfold_locales
            interpret χ: cone J.comp C λ_.null› a λ_.null›
              apply unfold_locales
                  apply simp
              using dom_null cod_null comp_null
              by blast+
            have "∃!f. «f : a  t»  D.cones_map f τ = (λ_. null)"
              using τ.induced_arrowI [of "λ_.null" a] χ.cone_axioms
                    τ.is_universal [of a "λ_. null"]
              by simp
            moreover have "f. «f : a  t»  D.cones_map f τ = (λ_. null)"
              using τ.cone_axioms by auto
            ultimately show ?thesis by auto
          qed
        qed
        thus ?thesis by blast
      qed
    qed

    lemma is_category_with_terminal_object:
    shows "category_with_terminal_object C"
      ..

    sublocale category_with_terminal_object C ..

    sublocale category_with_finite_products
      using has_finite_limits has_finite_products_if_has_finite_limits
            has_limits_of_shape_def diagram_def
      by unfold_locales blast

    sublocale cartesian_category ..

  end

  locale category_with_pullbacks_and_terminal =
    category_with_pullbacks +
    category_with_terminal_object

  sublocale category_with_finite_limits  category_with_pullbacks_and_terminal ..

  text‹
    Conversely, we show that a category with pullbacks and a terminal object also
    has finite products and equalizers, and therefore has finite limits.
  ›

  context category_with_pullbacks_and_terminal
  begin

    interpretation ECP: elementary_category_with_pullbacks C prj0 prj1
      using extends_to_elementary_category_with_pullbacks by simp

    abbreviation prj0'
    where "prj0' a b  (if ide a  ide b then prj0 (trm a) (trm b) else null)"

    abbreviation prj1'
    where "prj1' a b  (if ide a  ide b then prj1 (trm a) (trm b) else null)"

    interpretation ECC: elementary_cartesian_category C prj0' prj1' 𝟭 trm
      using trm_naturality ECP.universal
      by unfold_locales auto

    interpretation category_with_equalizers C
    proof (unfold_locales, unfold has_equalizers_def, intro allI impI)
      fix f0 f1
      assume par: "par f0 f1"
      interpret J: parallel_pair
        by unfold_locales
      interpret D: parallel_pair_diagram C f0 f1
        using par by unfold_locales auto
      have 1: "cospan (ECC.prod f1 (dom f0)) (ECC.prod f0 (dom f0))"
        using par by simp
      let ?g0 = "ECC.prod f0 (dom f0)  ECC.dup (dom f0)"
      let ?g1 = "ECC.prod f1 (dom f1)  ECC.dup (dom f1)"
      have g0: "«?g0 : dom f0  ECC.prod (cod f0) (dom f0)»"
        using par by simp
      have g1: "«?g1 : dom f1  ECC.prod (cod f1) (dom f1)»"
        using par by simp
      define e0 where "e0 = prj0 ?g1 ?g0"
      define e1 where "e1 = prj1 ?g1 ?g0"
      have e0: "«e0 : dom e0  dom f0»"
        using par 1 e0_def by auto
      have e1: "«e1 : dom e0  dom f1»"
        using par 1 e1_def e0_def by auto
      have eq: "e0 = e1"
      proof -
        have "e1 = prj0' (cod f1) (dom f1)  ?g1  e1"
        proof -
          have "((prj0' (cod f1) (dom f1)  (ECC.prod f1 (dom f1)))  ECC.dup (dom f1))  e1 =
                dom f1  e1"
            using par ECC.pr_naturality(1) [of "dom f1" "dom f1" "dom f1" f1 "dom f1" "cod f1"]
                  comp_cod_arr ECC.pr_dup(1)
            by auto
          also have "... = e1"
            using par e1 comp_cod_arr by blast
          finally show ?thesis
            using comp_assoc by simp
        qed
        also have "... = prj0' (cod f1) (dom f1)  ?g0  e0"
          using par ECP.pullback_commutes
          unfolding commutative_square_def e0_def e1_def by simp
        also have "... = e0"
        proof -
          have "((prj0' (cod f1) (dom f1)  (ECC.prod f0 (dom f0)))  ECC.dup (dom f0))  e0 =
                dom f0  e0"
            using par ECC.pr_naturality(1) [of "dom f0" "dom f0" "dom f1" f0 "dom f0" "cod f0"]
                  comp_cod_arr ECC.pr_dup(1) ide_dom
            by auto
          also have "... = e0"
            using e0 comp_cod_arr by blast
          finally show ?thesis
            using comp_assoc by simp
        qed
        finally show ?thesis by auto
      qed
      have equalizes: "D.is_equalized_by e0"
      proof
        show "seq f0 e0"
          using par e0 by auto
        show "f0  e0 = f1  e0"
        proof -
          have "f0  e0 = (f0  dom f0)  e0"
            using par comp_arr_dom by simp
          also have "... = (f0  (prj1' (dom f0) (dom f0)  ECC.dup (dom f0)))  e0"
            using par ECC.pr_dup(2) by auto
          also have "... = ((f0  prj1' (dom f0) (dom f0))  ECC.dup (dom f0))  e0"
            using comp_assoc by auto
          also have "... = prj1' (cod f1) (dom f1)  ?g0  e0"
            using par ECC.pr_naturality(2) [of "dom f0" "dom f0" "dom f1" f0 "dom f0" "cod f0"]
            by (metis (no_types, lifting) arr_dom cod_dom dom_dom comp_assoc)
          also have "... = prj1' (cod f1) (dom f1)  ?g1  e1"
            using par ECP.pullback_commutes [of ?g1 ?g0]
            unfolding commutative_square_def e0_def e1_def by simp
          also have "... = (prj1' (cod f1) (dom f1)  ?g1)  e1"
            using comp_assoc by simp
          also have "... = (f1  (prj1' (dom f1) (dom f1)  ECC.dup (dom f1)))  e1"
            using par ECC.pr_naturality(2) [of "dom f1" "dom f1" "dom f1" f1 "dom f1" "cod f1"]
            by (metis (no_types, lifting) arr_dom cod_dom dom_dom comp_assoc)
          also have "... = (f1  dom f1)  e1"
            using par ECC.pr_dup(2) by auto
          also have "... = f1  e1"
            using par comp_arr_dom by simp
          also have "... = f1  e0"
            using eq by simp
          finally show ?thesis by simp
        qed
      qed
      show "e. has_as_equalizer f0 f1 e"
      proof
        interpret E: constant_functor J.comp C ‹dom e0
          using par e0 by unfold_locales auto
        interpret χ: cone J.comp C D.map ‹dom e0 ‹D.mkCone e0
          using equalizes D.cone_mkCone e0_def by auto
        interpret χ: limit_cone J.comp C D.map ‹dom e0 ‹D.mkCone e0
        proof
          show "a' χ'. D.cone a' χ' 
                         ∃!f. «f : a'  dom e0»  D.cones_map f (D.mkCone e0) = χ'"
          proof -
            fix a' χ'
            assume χ': "D.cone a' χ'"
            interpret χ': cone J.comp C D.map a' χ'
              using χ' by simp
            have 3: "commutative_square ?g1 ?g0 (χ' J.Zero) (χ' J.Zero)"
            proof
              show "cospan ?g1 ?g0"
                using par g0 g1 by simp
              show 4: "span (χ' J.Zero) (χ' J.Zero)"
                using J.arr_char by simp
              show 5: "dom ?g1 = cod (χ' J.Zero)"
                using par g1 J.arr_char D.map_def by simp
              show "?g1  χ' J.Zero = ?g0  χ' J.Zero"
              proof -
                have "?g1  χ' J.Zero = ECC.prod f1 (dom f1)  ECC.dup (dom f1)  χ' J.Zero"
                  using comp_assoc by simp
                also have "... = ECC.prod f1 (dom f1)  ECC.tuple (χ' J.Zero) (χ' J.Zero)"
                  using par D.map_def J.arr_char comp_cod_arr by auto
                also have "... = ECC.tuple (f1  χ' J.Zero) (χ' J.Zero)"
                  using par ECC.prod_tuple [of "χ' J.Zero" "χ' J.Zero" f1 "dom f1"]
                        comp_cod_arr
                  by (metis (no_types, lifting) 4 5 g1 in_homE seqI)
                also have "... = ECC.tuple (f0  χ' J.Zero) (χ' J.Zero)"
                  using par D.is_equalized_by_cone χ'.cone_axioms by auto
                also have "... = ECC.prod f0 (dom f0)  ECC.tuple (χ' J.Zero) (χ' J.Zero)"
                  using par ECC.prod_tuple [of "χ' J.Zero" "χ' J.Zero" f0 "dom f0"]
                        comp_cod_arr
                  by (metis (no_types, lifting) 4 5 g1 in_homE seqI)
                also have "... = ECC.prod f0 (dom f0)  ECC.dup (dom f0)  χ' J.Zero"
                  using par D.map_def J.arr_char comp_cod_arr by auto
                also have "... = ?g0  χ' J.Zero"
                  using comp_assoc by simp
                finally show ?thesis by blast
              qed
            qed
            show "∃!f. «f : a'  dom e0»  D.cones_map f (D.mkCone e0) = χ'"
            proof
              define f where "f = ECP.tuple (χ' J.Zero) ?g1 ?g0 (χ' J.Zero)"
              have 4: "e0  f = χ' J.Zero"
                using ECP.universal by (simp add: "3" e1_def eq f_def)
              have f: "«f : a'  dom e0»"
              proof -
                have "a' = dom (χ' J.Zero)"
                  by (simp add: J.arr_char)
                thus ?thesis
                  using 3 f_def e0_def g0 g1 ECP.tuple_in_hom ECP.pbdom_def by simp
              qed
              moreover have 5: "D.cones_map f (D.mkCone e0) = χ'"
              proof -
                have "j. J.arr j  D.mkCone e0 j  f = χ' j"
                proof -
                  fix j
                  assume j: "J.arr j"
                  show "D.mkCone e0 j  f = χ' j"
                  proof (cases "j = J.Zero")
                    case True
                    moreover have "e0  f = χ' J.Zero"
                      using 4 by simp
                    ultimately show ?thesis
                      unfolding f_def D.mkCone_def comp_assoc
                      using J.arr_char by simp
                    next
                    case F: False
                    hence 1: "(f0  e0)  f = f0  χ' J.Zero"
                      using 4 comp_assoc by simp
                    also have "... = χ' j"
                      by (metis (no_types, lifting) F D.mkCone_cone D.mkCone_def
                          χ'.cone_axioms j)
                    finally show ?thesis
                      by (simp add: F D.mkCone_def j)
                  qed
                qed
                thus ?thesis
                  using f e0 χ.cone_axioms χ'.is_extensional by auto
              qed
              ultimately show "«f : a'  dom e0»  D.cones_map f (D.mkCone e0) = χ'"
                by simp
              fix f'
              assume f': "«f' : a'  dom e0»  D.cones_map f' (D.mkCone e0) = χ'"
              show "f' = f"
              proof -
                have "e0  f' = χ' J.Zero"
                  using f' D.mkCone_cone D.mkCone_def χ'.cone_axioms
                        comp_assoc J.arr_char χ.cone_axioms
                  by auto
                thus ?thesis
                  using f' 3 4 eq ECP.universal [of ?g1 ?g0 "e1  f'" "e0  f'"] e0_def e1_def
                  by (metis (no_types, lifting))
              qed
            qed
          qed
        qed
        show "has_as_equalizer f0 f1 e0"
        proof -
          have "par f0 f1"
            by fact
          moreover have "D.has_as_equalizer e0"
            ..
          ultimately show ?thesis
            using has_as_equalizer_def by blast
        qed
      qed
    qed

    interpretation category_with_finite_products C
      by (simp add: ECC.is_cartesian_category cartesian_category.is_category_with_finite_products)

    lemma has_finite_products:
    shows "category_with_finite_products C"
      ..

    lemma has_finite_limits:
    shows "category_with_finite_limits C"
    proof
      fix J :: "nat comp"
      assume J: "category J"
      interpret J: category J
        using J by simp
      assume finite: "finite (Collect J.arr)"
      show "has_limits_of_shape J"
      proof -
        have "Collect (partial_magma.ide J)  Collect J.arr"
          by auto
        hence 1: "finite (Collect J.ide)"
          using finite finite_subset by blast
        have "has_products (Collect (partial_magma.ide J))"
          using 1 J.ideD(1) J.not_arr_null category_with_finite_products.has_finite_products
                is_category_with_finite_products
          by simp
        moreover have "Collect (partial_magma.ide J)  UNIV"
          using J.not_arr_null by blast
        moreover have "Collect (partial_magma.arr J)  UNIV"
          using J.not_arr_null by blast
        ultimately show ?thesis
          using finite 1 J.category_axioms has_limits_if_has_products
                has_finite_products' [of "Collect J.ide"]
                has_finite_products' [of "Collect J.arr"]
          by simp
      qed
    qed

    sublocale category_with_finite_limits C
      using has_finite_limits by simp

  end

end

Theory CartesianClosedCategory

(*  Title:       CartesianClosedCategory
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2020
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Cartesian Closed Category"

theory CartesianClosedCategory
imports CartesianCategory
begin

  text‹
    A \emph{cartesian closed category} is a cartesian category such that,
    for every object b›, the functor prod ‐ b› is a left adjoint functor.
    A right adjoint to this functor takes each object c› to the \emph{exponential}
    exp b c›.  The adjunction yields a natural bijection between hom (prod a b) c›
    and hom a (exp b c)›.
  ›

  locale cartesian_closed_category =
    cartesian_category C
  for C :: "'a comp" +
  assumes left_adjoint_prod: "b. ide b  left_adjoint_functor C C (λx. prod x b)"

  locale elementary_cartesian_closed_category =
    elementary_cartesian_category C pr0 pr1 one trm
  for C :: "'a  'a  'a"  (infixr  55)
  and pr0 :: "'a  'a  'a"  (𝔭0[_, _])
  and pr1 :: "'a  'a  'a"  (𝔭1[_, _])
  and one :: "'a"              (𝟭)
  and trm :: "'a  'a"        (𝗍[_])
  and exp :: "'a  'a  'a"
  and eval :: "'a  'a  'a"
  and Λ :: "'a  'a  'a  'a  'a" +
  assumes eval_in_hom: " ide b; ide c   «eval b c : prod (exp b c) b  c»"
  and ide_exp: " ide b; ide c   ide (exp b c)"
  and lam_in_hom: " ide a; ide b; ide c; «g : prod a b  c»   «Λ a b c g : a  exp b c»"
  and eval_prod_lam: " ide a; ide b; ide c; «g : prod a b  c» 
                           C (eval b c) (prod (Λ a b c g) b) = g"
  and lam_eval_prod: " ide a; ide b; ide c; «h : a  exp b c» 
                           Λ a b c (C (eval b c) (prod h b)) = h"

  context cartesian_closed_category
  begin

    lemma has_exponentials:
    assumes "ide b" and "ide c"
    shows "x e. ide x  «e : prod x b  c» 
                 (a g. ide a  «g : prod a b  c»  (∃!f. «f : a  x»  g = C e (prod f b)))"
    proof -
      interpret F: left_adjoint_functor C C λx. prod x b
        using assms(1) left_adjoint_prod by simp
      obtain x e where e: "terminal_arrow_from_functor C C (λx. prod x b) x c e"
        using assms F.ex_terminal_arrow [of c] by auto
      interpret e: terminal_arrow_from_functor C C λx. prod x b x c e
        using e by simp
      have "a g.  ide a; «g : prod a b  c»   ∃!f. «f : a  x»  g = C e (prod f b)"
        using e.is_terminal category_axioms F.functor_axioms
        unfolding e.is_coext_def arrow_from_functor_def arrow_from_functor_axioms_def
        by simp
      thus ?thesis
        using e.arrow by metis
    qed

    definition exp
    where "exp b c  SOME x. ide x 
                              (e. «e : prod x b  c» 
                                   (a g. ide a  «g : prod a b  c»
                                            (∃!f. «f : a  x»  g = C e (prod f b))))"

    definition eval
    where "eval b c  SOME e. «e : prod (exp b c) b  c» 
                              (a g. ide a  «g : prod a b  c»
                                        (∃!f. «f : a  exp b c»  g = C e (prod f b)))"

    definition Λ
    where "Λ a b c g  THE f. «f : a  exp b c»  g = C (eval b c) (prod f b)"

    lemma ex_un_lam:
    assumes "ide b" and "ide c"
    shows "ide (exp b c)" and "«eval b c : prod (exp b c) b  c»"
    and " ide a; «g : prod a b  c»   ∃!f. «f : a  exp b c»  g = C (eval b c) (prod f b)"
      using assms exp_def eval_def has_exponentials
            someI_ex [of "λx. ide x  (e. «e : prod x b  c» 
                                           (a g. ide a  «g : prod a b  c»
                                               (∃!f. «f : a  x»  g = C e (prod f b))))"]
            someI_ex [of "λe. «e : prod (exp b c) b  c» 
                              (a g. ide a  «g : prod a b  c»
                                            (∃!f. «f : a  exp b c»  g = C e (prod f b)))"]
      by auto

    lemma eval_in_hom [intro]:
    assumes "ide b" and "ide c"
    shows "«eval b c : prod (exp b c) b  c»"
      using assms ex_un_lam by simp

    lemma eval_prod_lam:
    assumes "ide a" and "ide b" and "ide c" and "«g : prod a b  c»"
    shows "«Λ a b c g : a  exp b c»  g = C (eval b c) (prod (Λ a b c g) b)"
      using assms Λ_def ex_un_lam
            theI' [of "λf. «f : a  exp b c»  g = C (eval b c) (prod f b)"]
      by simp

    lemma lam_eval_prod:
    assumes "ide a" and "ide b" and "ide c" and "«h : a  exp b c»"
    shows a b c (C (eval b c) (prod h b)) = h"
    proof -
      have "∃!f. «f : a  exp b c»  C (eval b c) (prod h b) = C (eval b c) (prod f b)"
      proof -
        have "ide a  «C (eval b c) (prod h b) : prod a b  c»"
        proof (intro conjI)
          show "ide a" by fact
          show "«C (eval b c) (prod h b) : prod a b  c»"
            using assms by (intro comp_in_homI) auto
        qed
        thus ?thesis
          using assms ex_un_lam by simp
      qed
      moreover have "«h : a  exp b c»  C (eval b c) (prod h b) = C (eval b c) (prod h b)"
        using assms by simp
      ultimately show ?thesis
        using assms Λ_def ex_un_lam eval_prod_lam
              the1_equality [of "λf. «f : a  exp b c» 
                                     C (eval b c) (prod h b) = C (eval b c) (prod f b)"]
        by simp
    qed

    interpretation elementary_cartesian_closed_category C pr0 pr1 𝟭 trm exp eval Λ
      using eval_in_hom ex_un_lam eval_prod_lam lam_eval_prod
      apply unfold_locales by auto

    lemma induces_elementary_cartesian_closed_category:
    shows "elementary_cartesian_closed_category C pr0 pr1 𝟭 trm exp eval Λ"
      ..

  end

  context elementary_cartesian_closed_category
  begin

    lemma left_adjoint_prod:
    assumes "ide b"
    shows "left_adjoint_functor C C (λx. x  b)"
    proof -
      interpret "functor" C C λx. x  b
      proof
        show "f. ¬ arr f  f  b = null"
          using tuple_ext prod_def by auto
        fix f
        show "arr f  dom (f  b) = dom f  b"
          using assms by simp
        show "arr f  arr (f  b)"
          using assms by simp
        show "arr f  cod (f  b) = cod f  b"
          using assms by simp
        fix g
        show "seq g f  g  f  b = (g  b)  (f  b)"
          using assms interchange by simp
      qed
      interpret left_adjoint_functor C C λx. x  b
      proof
        show "c. ide c  x e. terminal_arrow_from_functor C C (λx. x  b) x c e"
        proof -
          fix c
          assume c: "ide c"
          show "x e. terminal_arrow_from_functor C C (λx. x  b) x c e"
          proof (intro exI)
            interpret arrow_from_functor C C λx. x  b exp b c c eval b c
            proof
              show "ide (exp b c)  «eval b c : exp b c  b  c»"
              proof (intro conjI)
                show "«eval b c : exp b c  b  c»"
                  using assms c eval_in_hom by simp
                show "ide (exp b c)"
                  using assms c ide_exp by simp
              qed
            qed
            interpret terminal_arrow_from_functor C C λx. x  b exp b c c eval b c
            proof
              show "a f. arrow_from_functor C C (λx. x  b) a c f 
                            ∃!g. arrow_from_functor.is_coext C C
                                   (λx. x  b) (exp b c) (eval b c) a f g"
              proof -
                fix a f
                assume f: "arrow_from_functor C C (λx. x  b) a c f"
                interpret f: arrow_from_functor C C λx. x  b a c f
                  using f by simp
                show "∃!g. is_coext a f g"
                proof
                  have a: "ide a"
                    using f.arrow by simp
                  show "is_coext a f (Λ a b c f)"
                    unfolding is_coext_def
                    using assms a c lam_in_hom [of a b c f] eval_prod_lam [of a b c f]
                          f.arrow
                    by simp
                  show "g. is_coext a f g  g = Λ a b c f"
                    unfolding is_coext_def
                    using assms a c lam_eval_prod [of a b c] f.arrow by simp
                qed
              qed
            qed
            show "terminal_arrow_from_functor C C (λx. x  b) (exp b c) c (eval b c)" ..
          qed
        qed
      qed
      show ?thesis ..
    qed

    interpretation CCC: cartesian_category C
      using is_cartesian_category by simp

    interpretation CCC: cartesian_closed_category C
    proof
      fix b
      assume b: "ide b"
      interpret left_adjoint_functor C C λx. CCC.prod x b
      proof -
        (*
         * We know that (λx. x ⊗ b) is a left adjoint functor, where ⊗ is the
         * product ultimately defined in terms of the projections that are parameters
         * to the elementary_category_with_binary_products locale that is the present context.
         * This is not necessarily the same as (λx. CCC.prod x b), which is defined in terms
         * of projections chosen arbitrarily in category_with_binary_products.
         * However, since they are both categorical products, they are naturally isomorphic,
         * so one is a left adjoint functor if and only if the other is.
         *)
        have "naturally_isomorphic C C (λx. x  b) (λx. CCC.prod x b)"
        proof -
          interpret CC: product_category C C ..
          interpret X: binary_functor C C C λfg. fst fg  snd fg
            using binary_functor_Prod(1) by auto
          interpret Xb: "functor" C C λx. x  b
            using b X.fixing_ide_gives_functor_2 by simp
          interpret prod: binary_functor C C C λfg. CCC.prod (fst fg) (snd fg)
            using CCC.binary_functor_Prod(1) by simp
          interpret prod_b: "functor" C C λx. CCC.prod x b
             using b prod.fixing_ide_gives_functor_2 by simp
          interpret φ: transformation_by_components C C λx. x  b λx. CCC.prod x b
                         λa. CCC.tuple (pr1 a b) (pr0 a b)
            using b CCC.prod_tuple by unfold_locales auto
          interpret φ: natural_isomorphism C C λx. x  b λx. CCC.prod x b φ.map
          proof
            fix a
            assume a: "ide a"
            show "iso (φ.map a)"
            proof
              show "inverse_arrows (φ.map a) CCC.pr1 a b, CCC.pr0 a b"
                using a b by auto
            qed
          qed
          show ?thesis
            using naturally_isomorphic_def φ.natural_isomorphism_axioms by blast
        qed
        moreover have "left_adjoint_functor C C (λx. x  b)"
          using b left_adjoint_prod [of b] by simp
        ultimately show "left_adjoint_functor C C (λx. CCC.prod x b)"
          using left_adjoint_functor_respects_naturally_isomorphic by auto
      qed
      show "f. ¬ arr f  CCC.prod f b = null"
        using is_extensional by blast
      show "f. arr f  dom (CCC.prod f b) = CCC.prod (dom f) b"
        by simp
      show "f. arr f  cod (CCC.prod f b) = CCC.prod (cod f) b"
        by simp
      show "f. arr f  arr (CCC.prod f b)"
        by simp
      show "g f. seq g f  CCC.prod (g  f) b = CCC.prod g b  CCC.prod f b"
        by simp
      show "y. ide y  x e. terminal_arrow_from_functor (⋅) (⋅) (λx. CCC.prod x b) x y e"
        using ex_terminal_arrow by simp
    qed

    lemma is_cartesian_closed_category:
    shows "cartesian_closed_category C"
      ..

  end

end

Theory HFSetCat

(*  Title:       HFSetCat
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2020
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "The Category of Hereditarily Finite Sets"

theory HFSetCat
imports CategoryWithFiniteLimits CartesianClosedCategory HereditarilyFinite.HF
begin

  text‹
    This theory constructs a category whose objects are in bijective correspondence with
    the hereditarily finite sets and whose arrows correspond to the functions between such
    sets.  We show that this category is cartesian closed and has finite limits.
    Note that up to this point we have not constructed any other interpretation for the
    @{locale cartesian_closed_category} locale, but it is important to have one to ensure
    that the locale assumptions are consistent.
  ›

  section "Preliminaries"

  text‹
    We begin with some preliminary definitions and facts about hereditarily finite sets,
    which are better targeted toward what we are trying to do here than what already exists
    in @{theory HereditarilyFinite.HF}.
  ›

  text‹
    The following defines when a hereditarily finite set F› represents a function from
    a hereditarily finite set B› to a hereditarily finite set C›.  Specifically, F›
    must be a relation from B› to C›, whose domain is B›, whose range is contained in C›,
    and which is single-valued on its domain.
  ›

  definition hfun
  where "hfun B C F  F  B * C  hfunction F  hdomain F = B  hrange F  C"

  lemma hfunI [intro]:
  assumes "F  A * B"
  and "X. X  A  ∃!Y. X, Y  F"
  and "X Y. X, Y  F  Y  B"
  shows "hfun A B F"
    unfolding hfun_def
    using assms hfunction_def hrelation_def is_hpair_def hrange_def hconverse_def hdomain_def
    apply (intro conjI)
    apply auto
    by fast

  lemma hfunE [elim]:
  assumes "hfun B C F"
  and "(Y. Y  B  (∃!Z. Y, Z  F)  (Z. Y, Z  F  Z  C))  T"
  shows T
  proof -
    have "Y. Y  B  (∃!Z. Y, Z  F)  (Z. Y, Z  F  Z  C)"
    proof (intro allI impI conjI)
      fix Y
      assume Y: "Y  B"
      show "∃!Z. Y, Z  F"
      proof -
        have "Z. Y, Z  F"
          using assms Y hfun_def hdomain_def by auto
        moreover have "Z Z'.  Y, Z  F; Y, Z'  F   Z = Z'"
          using assms hfun_def hfunction_def by simp
        ultimately show ?thesis by blast
      qed
      show "Z. Y, Z  F  Z  C"
        using assms Y hfun_def by auto
    qed
    thus ?thesis
      using assms(2) by simp
  qed

  text‹
    The hereditarily finite set hexp B C› represents the collection of all functions
    from B› to C›.
  ›

  definition hexp
  where "hexp B C = F  HPow (B * C). hfun B C F"

  lemma hfun_in_hexp:
  assumes "hfun B C F"
  shows "F  hexp B C"
    using assms by (simp add: hexp_def hfun_def)

  text‹
    The function happ› applies a function F› from B› to C› to an element of B›,
    yielding an element of C›.
  ›

  abbreviation happ
  where "happ  app"

  lemma happ_mapsto:
  assumes "F  hexp B C" and "Y  B"
  shows "happ F Y  C" and "happ F Y  hrange F"
  proof -
    show "happ F Y  C"
      using assms app_def hexp_def app_equality hdomain_def hfun_def by auto
    show "happ F Y  hrange F"
    proof -
      have "Y, happ F Y  F"
        using assms app_def hexp_def app_equality hdomain_def hfun_def by auto
      thus ?thesis
        using hdomain_def hrange_def hconverse_def by auto
    qed
  qed

  lemma happ_expansion:
  assumes "hfun B C F"
  shows "F = XY  B * C. hsnd XY = happ F (hfst XY)"
  proof
    fix XY
    show "XY  F  XY  XY  B * C. hsnd XY = happ F (hfst XY)"
    proof
      show "XY  F  XY  XY  B * C. hsnd XY = happ F (hfst XY)"
      proof -
        assume XY: "XY  F"
        have "XY  B * C"
          using assms XY hfun_def by auto
        moreover have "hsnd XY = happ F (hfst XY)"
          using assms XY hfunE app_def [of F "hfst XY"] the1_equality [of "λy. hfst XY, y  F"]
                calculation
          by auto
        ultimately show "XY  XY  B * C. hsnd XY = happ F (hfst XY)" by simp
      qed
      show "XY  XY  B * C. hsnd XY = happ F (hfst XY)  XY  F"
      proof -
        assume XY: "XY  XY  B * C. hsnd XY = happ F (hfst XY)"
        show "XY  F"
          using assms XY app_def [of F "hfst XY"] the1_equality [of "λy. hfst XY, y  F"]
          by fastforce
      qed
    qed
  qed

  text‹
    Function hlam› takes a function F› from A * B› to C› to a function hlam F›
    from A› to hexp B C›.
  ›

  definition hlam
  where "hlam A B C F =
         XG  A * hexp B C.
            YZ. YZ  hsnd XG  is_hpair YZ  hfst XG, hfst YZ, hsnd YZ  F"

  lemma hfun_hlam:
  assumes "hfun (A * B) C F"
  shows "hfun A (hexp B C) (hlam A B C F)"
  proof
    show "hlam A B C F  A * hexp B C"
      using assms hlam_def by auto
    show "X. X  A  ∃!Y. X, Y  hlam A B C F"
    proof
      fix X
      assume X: "X  A"
      let ?G = "YZ  B * C. X, hfst YZ, hsnd YZ  F"
      have 1: "?G  hexp B C"
        using assms X hexp_def by fastforce
      show "X, ?G  hlam A B C F"
        using assms X 1 is_hpair_def hfun_def hlam_def by auto
      fix Y
      assume XY: "X, Y  hlam A B C F"
      show "Y = ?G"
        using assms X XY hlam_def hexp_def by fastforce
    qed
    show "X Y. X, Y  hlam A B C F  Y  hexp B C"
      using assms hlam_def hexp_def by simp
  qed

  lemma happ_hlam:
  assumes "X  A" and "hfun (A * B) C F"
  shows "∃!G. X, G  hlam A B C F"
  and "happ (hlam A B C F) X = (THE G. X, G  hlam A B C F)"
  and "happ (hlam A B C F) X = yz  B * C. X, hfst yz, hsnd yz  F"
  and "Y  B  happ (happ (hlam A B C F) X) Y = happ F X, Y"
  proof -
    show 1: "∃!G. X, G  hlam A B C F"
      using assms(1,2) hfun_hlam hfunE
      by (metis (full_types))
    show 2: "happ (hlam A B C F) X = (THE G. X, G  hlam A B C F)"
      using assms app_def by simp
    show "happ (happ (hlam A B C F) X) Y = happ F X, Y"
    proof -
      have 3: "X, happ (hlam A B C F) X  hlam A B C F"
        using assms(1) 1 2 theI' [of "λG. X, G  hlam A B C F"] by simp
      hence "∃!Z. happ (happ (hlam A B C F) X) = Z"
        by simp
      moreover have "happ (happ (hlam A B C F) X) Y = happ F X, Y"
        using assms(1-2) 3 hlam_def is_hpair_def app_def by simp
      ultimately show ?thesis by simp
    qed
    show "happ (hlam A B C F) X = YZ  B * C. X, hfst YZ, hsnd YZ  F"
    proof -
      let ?G = "YZ  B * C. X, hfst YZ, hsnd YZ  F"
      have 4: "hfun B C ?G"
      proof
        show "YZ  B * C. X, hfst YZ, hsnd YZ  F  B * C"
          using assms by auto
        show "Y. Y  B  ∃!Z. Y, Z  YZ  B * C. X, hfst YZ, hsnd YZ  F"
        proof -
          fix Y
          assume Y: "Y  B"
          have XY: "X, Y  A * B"
            using assms Y by simp
          hence 1: "∃!Z. X, Y, Z  F"
            using assms XY hfunE [of "A * B" C F] by blast
          obtain Z where Z: "X, Y, Z  F"
            using 1 by auto
          have "Z. Y, Z  YZ  B * C. X, hfst YZ, hsnd YZ  F"
          proof -
            have "Y, Z  B * C"
              using assms Y Z by blast
            moreover have "X, hfst Y, Z, hsnd Y, Z  F"
              using assms Y Z by simp
            ultimately show ?thesis by auto
          qed
          moreover have "Z Z'. Y, Z  YZ  B * C. X, hfst YZ, hsnd YZ  F;
                                 Y, Z'  YZ  B * C. X, hfst YZ, hsnd YZ  F  Z = Z'"
            using assms Y by auto
          ultimately show "∃!Z. Y, Z  YZ  B * C. X, hfst YZ, hsnd YZ  F"
            by auto
        qed
        show "Y Z. Y, Z  YZ  B * C. X, hfst YZ, hsnd YZ  F  Z  C"
          using assms by simp
      qed
      have "X, ?G  hlam A B C F"
      proof -
        have "X, ?G  A * hexp B C"
          using assms 4
          by (simp add: hfun_in_hexp)
        moreover have "YZ. YZ  ?G  is_hpair YZ  X, hfst YZ, hsnd YZ  F"
          using assms 1 is_hpair_def hfun_def by auto
        ultimately show ?thesis
          using assms 1 hlam_def by simp
      qed
      thus "happ (hlam A B C F) X = ?G"
        using assms 2 4 app_equality hfun_def hfun_hlam by auto
    qed
  qed

  section "Construction of the Category"

  locale hfsetcat
  begin

    text‹
      We construct the category of hereditarily finite sets and function simply by applying
      the generic ``set category'' construction, using the hereditarily finite sets as the
      universe, and constraining the collections of such sets that determine objects of the
      category to those having cardinality less than that of the natural numbers;
      \emph{i.e.}~to those that are finite.
    ›

    interpretation setcat ‹undefined :: hf› natLeq
      using Field_natLeq natLeq_Card_order
      by unfold_locales auto

    interpretation category_with_terminal_object comp
      using terminal_unity by unfold_locales auto

    text‹
      We verify that the objects of HF are indeed in bijective correspondence with the
      hereditarily finite sets.
    ›

    definition ide_to_hf
    where "ide_to_hf a = HF (DOWN ` set a)"

    definition hf_to_ide
    where "hf_to_ide x = mkIde (UP ` hfset x)"

    lemma ide_to_hf_mapsto:
    shows "ide_to_hf  Collect ide  UNIV"
      by simp

    lemma hf_to_ide_mapsto:
    shows "hf_to_ide  UNIV  Collect ide"
    proof
      fix x :: hf
      have "finite (UP ` hfset x)"
        by simp
      moreover have "UP ` hfset x  Univ"
        by (metis (mono_tags, lifting) UNIV_I bij_UP bij_betw_def imageE image_eqI subsetI)
      ultimately have "ide (mkIde (UP ` hfset x))"
        using ide_mkIde_finite by simp
      thus "hf_to_ide x  Collect ide"
        using hf_to_ide_def by simp
    qed

    lemma hf_to_ide_ide_to_hf:
    assumes "a  Collect ide"
    shows "hf_to_ide (ide_to_hf a) = a"
    proof -
      have "hf_to_ide (ide_to_hf a) = mkIde (UP ` hfset (HF (DOWN ` set a)))"
        using hf_to_ide_def ide_to_hf_def by simp
      also have "... = a"
      proof -
        have "mkIde (UP ` hfset (HF (DOWN ` set a))) = mkIde (UP ` DOWN ` set a)"
        proof -
          have "finite (set a)"
            using assms set_card finite_iff_ordLess_natLeq by auto
          hence "finite (DOWN ` set a)"
            by simp
          hence "hfset (HF (DOWN ` set a)) = DOWN ` set a"
            using hfset_HF [of "DOWN ` set a"] by simp
          thus ?thesis by simp
        qed
        also have "... = a"
        proof -
          have "set a  Univ"
            using assms set_subset_Univ ide_char by blast
          hence "x. x  set a  UP (DOWN x) = x"
            using assms by auto
          hence "UP ` DOWN ` set a = set a"
            by force
          thus ?thesis
            using assms ide_char mkIde_set by simp
        qed
        finally show ?thesis by blast
      qed
      finally show "hf_to_ide (ide_to_hf a) = a" by blast
    qed

    lemma ide_to_hf_hf_to_ide:
    assumes "x  UNIV"
    shows "ide_to_hf (hf_to_ide x) = x"
    proof -
      have "HF (DOWN ` set (mkIde (UP ` hfset x))) = x"
      proof -
        have "HF (DOWN ` set (mkIde (UP ` hfset x))) = HF (DOWN ` UP ` hfset x)"
        proof -
          have "|UP ` hfset x| <o natLeq"
            using assms finite_iff_ordLess_natLeq finite_hfset by blast
          thus ?thesis
            using assms set_mkIde [of "UP ` hfset x"] UP_mapsto mkIde_def by auto
        qed
        also have "... = HF (hfset x)"
        proof -
          have "A. DOWN ` UP ` A = A"
            using DOWN_UP by force
          thus ?thesis by metis
        qed
        also have "... = x" by simp
        finally show ?thesis by blast
      qed
      thus ?thesis
        using assms ide_to_hf_def hf_to_ide_def by simp
    qed

    lemma bij_betw_ide_hf_set:
    shows "bij_betw ide_to_hf (Collect ide) (UNIV :: hf set)"
      using ide_to_hf_mapsto hf_to_ide_mapsto ide_to_hf_hf_to_ide hf_to_ide_ide_to_hf
      by (intro bij_betwI) auto

    lemma ide_implies_finite_set:
    assumes "ide a"
    shows "finite (set a)" and "finite (hom unity a)"
    proof -
      show 1: "finite (set a)"
        using assms ide_char set_card finite_iff_ordLess_natLeq by blast
      show "finite (hom unity a)"
      proof -
        have "|hom unity a| =o |set a|"
          using assms bij_betw_points_and_set card_of_ordIsoI by auto
        thus ?thesis
          using 1 by simp
      qed
    qed

    text‹
      We establish the connection between the membership relation defined for hereditarily
      finite sets and the corresponding membership relation associated with the set category.
    ›

    lemma UP_membI [intro]:
    assumes "x  ide_to_hf a"
    shows "UP x  set a"
    proof -
      let ?X = "inv_into (set a) DOWN x"
      have "x = DOWN ?X  ?X  set a"
        using assms
        by (simp add: f_inv_into_f ide_to_hf_def inv_into_into)
      thus ?thesis
        by (metis (no_types, lifting) UP_DOWN elem_set_implies_incl_in incl_in_def
            set_subset_Univ subsetD)
    qed

    lemma DOWN_membI [intro]:
    assumes "ide a" and "x  set a"
    shows "DOWN x  ide_to_hf a"
    proof -
      have "finite (DOWN ` set a)"
        using assms ide_implies_finite_set [of a] by simp
      hence "DOWN x  hfset (ide_to_hf a)"
        using assms ide_to_hf_def hfset_HF [of "DOWN ` set a"] by simp
      thus ?thesis
        using hmem_def by blast
    qed

    text‹
      We show that each hom-set hom a b› is in bijective correspondence with
      the elements of the hereditarily finite set hfun (ide_to_hf a) (ide_to_hf b)›.
    ›

    definition arr_to_hfun
    where "arr_to_hfun f = XY  ide_to_hf (dom f) * ide_to_hf (cod f).
                              hsnd XY = DOWN (Fun f (UP (hfst XY)))"

    definition hfun_to_arr
    where "hfun_to_arr B C F =
           mkArr (UP ` hfset B) (UP ` hfset C) (λx. UP (happ F (DOWN x)))"

    lemma hfun_arr_to_hfun:
    assumes "arr f"
    shows "hfun (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f)"
    proof
      show "arr_to_hfun f  ide_to_hf (dom f) * ide_to_hf (cod f)"
        using assms arr_to_hfun_def by auto
      show "X. X  ide_to_hf (dom f)  ∃!Y. X, Y  arr_to_hfun f"
      proof
        fix X
        assume X: "X  ide_to_hf (dom f)"
        show "X, DOWN (Fun f (UP X))  arr_to_hfun f"
        proof -
          have "X, DOWN (Fun f (UP X))  XY  ide_to_hf (dom f) * ide_to_hf (cod f).
                     hsnd XY = DOWN (Fun f (UP (hfst XY)))"
          proof -
            have "hsnd X, DOWN (Fun f (UP X)) =
                  DOWN (Fun f (UP (hfst X, DOWN (Fun f (UP X)))))"
              using assms X by simp
            moreover have "X, DOWN (Fun f (UP X))  ide_to_hf (dom f) * ide_to_hf (cod f)"
            proof -
              have "DOWN (Fun f (UP X))  ide_to_hf (cod f)"
              proof (intro DOWN_membI)
                show "ide (cod f)"
                  using assms ide_cod by simp
                show "Fun f (UP X)  Cod f"
                  using assms X Fun_mapsto UP_membI by auto
              qed
              thus ?thesis
                using X by simp
            qed
            ultimately show ?thesis by simp
          qed
          thus ?thesis
            using arr_to_hfun_def by simp
        qed
        fix Y
        assume XY: "X, Y  arr_to_hfun f"
        show "Y = DOWN (Fun f (UP X))"
          using assms X XY arr_to_hfun_def by auto
      qed
      show "X Y. X, Y  arr_to_hfun f  Y  ide_to_hf (cod f)"
        using assms arr_to_hfun_def ide_to_hf_def
              ‹arr_to_hfun f  ide_to_hf (dom f) * ide_to_hf (cod f)
        by blast
    qed

    lemma arr_to_hfun_in_hexp:
    assumes "arr f"
    shows "arr_to_hfun f  hexp (ide_to_hf (dom f)) (ide_to_hf (cod f))"
      using assms arr_to_hfun_def hfun_arr_to_hfun hexp_def by auto

    lemma hfun_to_arr_in_hom:
    assumes "hfun B C F"
    shows "«hfun_to_arr B C F : hf_to_ide B  hf_to_ide C»"
    proof
      let ?f = "mkArr (UP ` hfset B) (UP ` hfset C) (λx. UP (happ F (DOWN x)))"
      have 0: "arr ?f"
      proof -
        have "UP ` hfset B  Univ  UP ` hfset C  Univ"
          using UP_mapsto by auto
        moreover have "(λx. UP (happ F (DOWN x)))  UP ` hfset B  UP ` hfset C"
        proof
          fix x
          assume x: "x  UP ` hfset B"
          have "happ F (DOWN x)  hfset C"
            using assms x happ_mapsto hfun_in_hexp
            by (metis DOWN_UP HF_hfset finite_hfset hmem_HF_iff imageE)
          thus "UP (happ F (DOWN x))  UP ` hfset C"
            by simp
        qed
        ultimately show ?thesis
          using arr_mkArr
          by (meson finite_hfset finite_iff_ordLess_natLeq finite_imageI)
      qed
      show 1: "arr (hfun_to_arr B C F)"
        using 0 hfun_to_arr_def by simp
      show "dom (hfun_to_arr B C F) = hf_to_ide B"
        using 1 hfun_to_arr_def hf_to_ide_def dom_mkArr by auto
      show "cod (hfun_to_arr B C F) = hf_to_ide C"
        using 1 hfun_to_arr_def hf_to_ide_def cod_mkArr by auto
    qed

    text‹
      The comprehension notation from @{theory HereditarilyFinite.HF} interferes in an
      unfortunate way with the restriction notation from @{theory "HOL-Library.FuncSet"},
      making it impossible to use both in the present context.
    ›

    lemma Fun_char:
    assumes "arr f"
    shows "Fun f = restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f)"
    proof
      fix x
      show "Fun f x = restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f) x"
      proof (cases "x  Dom f")
        show "x  Dom f  ?thesis"
          using assms Fun_mapsto Fun_def restrict_apply by simp
        show "x  Dom f  ?thesis"
        proof -
          assume x: "x  Dom f"
          have 1: "hfun (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f)"
            using assms app_def arr_to_hfun_def hfun_arr_to_hfun
                  the1_equality [of "λy. DOWN x, y  arr_to_hfun f" "DOWN (Fun f x)"]
            by simp
          have 2: "∃!Y. DOWN x, Y  arr_to_hfun f"
            using assms x 1 hfunE DOWN_membI ide_dom
            by (metis (no_types, lifting))
          have "Fun f x = UP (DOWN (Fun f x))"
          proof -
            have "Fun f x  Univ"
              using assms x ide_cod Fun_mapsto [of f] set_subset_Univ by auto
            thus ?thesis
              using UP_DOWN by simp
          qed
          also have "... = UP (happ (arr_to_hfun f) (DOWN x))"
          proof -
            have "DOWN x, DOWN (Fun f x)  arr_to_hfun f"
              using assms x 2 ide_dom arr_to_hfun_def set_subset_Univ UP_DOWN
              by (metis (mono_tags, lifting) HCollectE hfst_conv hsnd_conv subsetD)
            moreover have "DOWN x, happ (arr_to_hfun f) (DOWN x)  arr_to_hfun f"
              using assms x 1 2 app_equality hfun_def by blast
            ultimately show ?thesis
              using 2 by fastforce
          qed
          also have "... = restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f) x"
            using assms x ide_dom by auto
          finally show ?thesis by simp
        qed
      qed
    qed

    lemma Fun_hfun_to_arr:
    assumes "hfun B C F"
    shows "Fun (hfun_to_arr B C F) = restrict (λx. UP (happ F (DOWN x))) (UP ` hfset B)"
    proof -
      have "arr (hfun_to_arr B C F)"
        using assms hfun_to_arr_in_hom by blast
      hence "arr (mkArr (UP ` hfset B) (UP ` hfset C) (λx. UP (happ F (DOWN x))))"
        using hfun_to_arr_def by simp
      thus ?thesis
        using assms hfun_to_arr_def Fun_mkArr by simp
    qed

    lemma UP_img_hfset_ide_to_hf:
    assumes "ide a"
    shows "UP ` hfset (ide_to_hf a) = set a"
    proof -
      have "UP ` hfset (ide_to_hf a) = UP ` hfset (HF (DOWN ` set a))"
        using ide_to_hf_def by simp
      also have "... = UP ` DOWN ` set a"
        using assms ide_implies_finite_set(1) ide_char by auto
      also have "... = set a"
      proof -
        have "x. x  set a  UP (DOWN x) = x"
          using assms ide_char
          by (metis (no_types, lifting) UP_DOWN set_subset_Univ subsetD)
        thus ?thesis by force
      qed
      finally show ?thesis by blast
    qed

    lemma hfun_to_arr_arr_to_hfun:
    assumes "arr f"
    shows "hfun_to_arr (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f) = f"
    proof -
      have 0: "hfun_to_arr (ide_to_hf (dom f)) (ide_to_hf (cod f)) (arr_to_hfun f) =
               mkArr (UP ` hfset (ide_to_hf (dom f))) (UP ` hfset (ide_to_hf (cod f)))
                     (λx. UP (happ (arr_to_hfun f) (DOWN x)))"
        unfolding hfun_to_arr_def by blast
      also have "... = mkArr (Dom f) (Cod f)
                             (restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f))"
      proof (intro mkArr_eqI)
        show 1: "UP ` hfset (ide_to_hf (dom f)) = Dom f"
          using assms UP_img_hfset_ide_to_hf ide_dom by simp
        show 2: "UP ` hfset (ide_to_hf (cod f)) = Cod f"
          using assms UP_img_hfset_ide_to_hf ide_cod by simp
        show "arr (mkArr (UP ` hfset (ide_to_hf (dom f))) (UP ` hfset (ide_to_hf (cod f)))
                         (λx. UP (happ (arr_to_hfun f) (DOWN x))))"
          using 0 1 2
          by (metis (no_types, lifting) arrI assms hfun_arr_to_hfun hfun_to_arr_in_hom)
        show "x. x  UP ` hfset (ide_to_hf (dom f)) 
                     UP (happ (arr_to_hfun f) (DOWN x)) =
                     restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f) x"
          using assms 1 by simp
      qed
      also have "... = mkArr (Dom f) (Cod f) (Fun f)"
        using assms Fun_char mkArr_eqI by simp
      also have "... = f"
        using assms mkArr_Fun by blast
      finally show ?thesis by simp
    qed

    lemma arr_to_hfun_hfun_to_arr:
    assumes "hfun B C F"
    shows "arr_to_hfun (hfun_to_arr B C F) = F"
    proof -
      have "arr_to_hfun (hfun_to_arr B C F) =
            XY  ide_to_hf (dom (hfun_to_arr B C F)) * ide_to_hf (cod (hfun_to_arr B C F)).
               hsnd XY = DOWN (Fun (hfun_to_arr B C F) (UP (hfst XY)))"
        unfolding arr_to_hfun_def by blast
      also have
          "... = XY  ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
                    hsnd XY = DOWN (Fun (hfun_to_arr B C F) (UP (hfst XY)))"
        using assms hfun_to_arr_in_hom [of B C F] hf_to_ide_def
        by (metis (no_types, lifting) in_homE)
      also have
          "... = XY  ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
                    hsnd XY = DOWN (restrict (λx. UP (happ F (DOWN x))) (UP ` hfset B)
                                   (UP (hfst XY)))"
        using assms Fun_hfun_to_arr by simp
      also have
          "... = XY  ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
                    hsnd XY = DOWN (UP (happ F (DOWN (UP (hfst XY)))))"
      proof -
        have
          1: "XY. XY  ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C))
                      UP (hfst XY)  UP ` hfset B"
        proof -
          fix XY
          assume
            XY: "XY  ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C))"
          have "hfst XY  ide_to_hf (mkIde (UP ` hfset B))"
            using XY by auto
          thus "UP (hfst XY)  UP ` hfset B"
            using assms UP_membI [of "hfst XY" "mkIde (UP ` hfset B)"] set_mkIde
            by (metis (mono_tags, lifting) arrI arr_mkArr hfun_to_arr_def hfun_to_arr_in_hom)
        qed
        show ?thesis
        proof -
          have
            "XY. (XY  ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)) 
                     hsnd XY = DOWN (restrict (λx. UP (happ F (DOWN x))) (UP ` hfset B)
                                       (UP (hfst XY))))
                   
                   (XY  ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)) 
                     hsnd XY = DOWN (UP (happ F (DOWN (UP (hfst XY))))))"
            using 1 by auto
          thus ?thesis by blast
        qed
      qed
      also have
        "... = XY  ide_to_hf (mkIde (UP ` hfset B)) * ide_to_hf (mkIde (UP ` hfset C)).
                  hsnd XY = happ F (hfst XY)"
        by simp
      also have "... = XY  B * C. hsnd XY = happ F (hfst XY)"
        using assms hf_to_ide_def ide_to_hf_hf_to_ide by force
      also have "... = F"
        using assms happ_expansion by simp
      finally show ?thesis by simp
    qed

    lemma bij_betw_hom_hfun:
    assumes "ide a" and "ide b"
    shows "bij_betw arr_to_hfun (hom a b) {F. hfun (ide_to_hf a) (ide_to_hf b) F}"
    proof (intro bij_betwI)
      show "arr_to_hfun  hom a b  {F. hfun (ide_to_hf a) (ide_to_hf b) F}"
        using assms arr_to_hfun_in_hexp hexp_def hfun_arr_to_hfun by blast
      show "hfun_to_arr (ide_to_hf a) (ide_to_hf b)
               {F. hfun (ide_to_hf a) (ide_to_hf b) F}  hom a b"
        using assms hfun_to_arr_in_hom
        by (metis (no_types, lifting) Pi_I hf_to_ide_ide_to_hf mem_Collect_eq)
      show "x. x  hom a b  hfun_to_arr (ide_to_hf a) (ide_to_hf b) (arr_to_hfun x) = x"
        using assms hfun_to_arr_arr_to_hfun by blast
      show "y. y  {F. hfun (ide_to_hf a) (ide_to_hf b) F} 
                  arr_to_hfun (hfun_to_arr (ide_to_hf a) (ide_to_hf b) y) = y"
        using assms arr_to_hfun_hfun_to_arr by simp
    qed

    text‹
      We next relate composition of arrows in the category to the corresponding operation
      on hereditarily finite sets.
    ›

    definition hcomp
    where "hcomp G F =
           XZ  hdomain F * hrange G. hsnd XZ = happ G (happ F (hfst XZ))"

    lemma hfun_hcomp:
    assumes "hfun A B F" and "hfun B C G"
    shows "hfun A C (hcomp G F)"
    proof
      show "hcomp G F  A * C"
        using assms hcomp_def hfun_def by auto
      show "X. X  A  ∃!Y. X, Y  hcomp G F"
      proof
        fix X
        assume X: "X  A"
        show "X, happ G (happ F X)  hcomp G F"
          unfolding hcomp_def
          using assms X hfunE happ_mapsto hfun_in_hexp
          by (metis (mono_tags, lifting) HCollect_iff hfst_conv hfun_def hsnd_conv timesI)
        show "X Y. X  A; X, Y  hcomp G F  Y = happ G (happ F X)"
          unfolding hcomp_def by simp
      qed
      show "X Y. X, Y  hcomp G F  Y  C"
        unfolding hcomp_def
        using assms hfunE happ_mapsto hfun_in_hexp
        by (metis HCollectE hfun_def hsubsetCE timesD2)
    qed

    lemma arr_to_hfun_comp:
    assumes "seq g f"
    shows "arr_to_hfun (comp g f) = hcomp (arr_to_hfun g) (arr_to_hfun f)"
    proof -
      have 1: "hdomain (arr_to_hfun f) = ide_to_hf (dom f)"
        using assms hfun_arr_to_hfun hfun_def by blast
      have "arr_to_hfun (comp g f) =
            XZ  ide_to_hf (dom f) * ide_to_hf (cod g).
               hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))"
        unfolding arr_to_hfun_def comp_def
        using assms by fastforce
      also have "... = XZ  hdomain (arr_to_hfun f) * hrange (arr_to_hfun g).
                          hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
      proof
        fix XZ
        have "hfst XZ  hdomain (arr_to_hfun f)
                  hsnd XZ  ide_to_hf (cod g) 
                       hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))
                      
                     hsnd XZ  hrange (arr_to_hfun g) 
                       hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
        proof
          assume XZ: "hfst XZ  hdomain (arr_to_hfun f)"
          have 2: "UP (hfst XZ)  Dom f"
            using XZ 1 hfsetcat.UP_membI by auto
          have 3: "UP (happ (arr_to_hfun f) (hfst XZ))  Dom g"
            using assms XZ 2
            by (metis (no_types, lifting) "1" happ_mapsto(1) hfsetcat.UP_membI
                arr_to_hfun_in_hexp seqE)
          have 4: "DOWN (Fun (comp g f) (UP (hfst XZ))) =
                   happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
          proof -
            have "DOWN (Fun (comp g f) (UP (hfst XZ))) =
                  DOWN (restrict (Fun g o Fun f) (Dom f) (UP (hfst XZ)))"
              using assms Fun_comp Fun_char by simp
            also have "... = DOWN ((Fun g o Fun f) (UP (hfst XZ)))"
              using XZ 2 by auto
            also have "... = DOWN (Fun g (Fun f (UP (hfst XZ))))"
              by simp
            also have
              "... = DOWN (Fun g (restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f)
                                           (UP (hfst XZ))))"
            proof -
              have "Fun f = restrict (λx. UP (happ (arr_to_hfun f) (DOWN x))) (Dom f)"
                using assms Fun_char [of f] by blast
              thus ?thesis by simp
            qed
            also have "... = DOWN (Fun g (UP (happ (arr_to_hfun f) (hfst XZ))))"
              using 2 by simp
            also have "... = DOWN (restrict (λx. UP (happ (arr_to_hfun g) (DOWN x))) (Dom g)
                                            (UP (happ (arr_to_hfun f) (hfst XZ))))"
            proof -
              have "Fun g = restrict (λx. UP (happ (arr_to_hfun g) (DOWN x))) (Dom g)"
                using assms Fun_char [of g] by blast
              thus ?thesis by simp
            qed
            also have "... = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
              using 3 by simp
            finally show ?thesis by blast
          qed
          have 5: "DOWN (Fun (comp g f) (UP (hfst XZ)))  hrange (arr_to_hfun g)"
          proof -
            have "happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))  hrange (arr_to_hfun g)"
              using assms 1 3 XZ hfun_arr_to_hfun happ_mapsto arr_to_hfun_in_hexp arr_to_hfun_def
              by (metis (no_types, lifting) seqE)
            thus ?thesis
              using XZ 4 by simp
          qed
          show "hsnd XZ  ide_to_hf (cod g) 
                  hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))
                          
                hsnd XZ  hrange (arr_to_hfun g) 
                  hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
            using XZ 4 5 by simp
          show "hsnd XZ  hrange (arr_to_hfun g) 
                  hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))
                          
                hsnd XZ  ide_to_hf (cod g) 
                  hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))"
            using assms XZ 1 4
            by (metis (no_types, lifting) arr_to_hfun_in_hexp happ_mapsto(1) seqE)
        qed
        thus "XZ  XZ  ide_to_hf (dom f) * ide_to_hf (cod g).
                      hsnd XZ = DOWN (Fun (comp g f) (UP (hfst XZ)))
                
              XZ  XZ  hdomain (arr_to_hfun f) * hrange (arr_to_hfun g).
                      hsnd XZ = happ (arr_to_hfun g) (happ (arr_to_hfun f) (hfst XZ))"
          using 1 is_hpair_def by auto
      qed
      also have "... = hcomp (arr_to_hfun g) (arr_to_hfun f)"
        using assms arr_to_hfun_def hcomp_def by simp
      finally show ?thesis by simp
    qed

    lemma hfun_to_arr_hcomp:
    assumes "hfun A B F" and "hfun B C G"
    shows "hfun_to_arr A C (hcomp G F) = comp (hfun_to_arr B C G) (hfun_to_arr A B F)"
    proof -
      have 1: "arr_to_hfun (hfun_to_arr A C (hcomp G F)) =
               arr_to_hfun (comp (hfun_to_arr B C G) (hfun_to_arr A B F))"
      proof -
        have "arr_to_hfun (comp (hfun_to_arr B C G) (hfun_to_arr A B F)) =
              hcomp (arr_to_hfun (hfun_to_arr B C G)) (arr_to_hfun (hfun_to_arr A B F))"
          using assms arr_to_hfun_comp hfun_to_arr_in_hom by blast
        also have "... = hcomp G F"
          using assms by (simp add: arr_to_hfun_hfun_to_arr)
        also have "... = arr_to_hfun (hfun_to_arr A C (hcomp G F))"
        proof -
          have "hfun A C (hcomp G F)"
            using assms hfun_hcomp by simp
          thus ?thesis
            by (simp add: arr_to_hfun_hfun_to_arr)
        qed
        finally show ?thesis by simp
      qed
      show ?thesis
      proof -
        have "hfun_to_arr A C (hcomp G F)  hom (hf_to_ide A) (hf_to_ide C)"
          using assms hfun_hcomp hf_to_ide_def hfun_to_arr_in_hom by auto
        moreover have "comp (hfun_to_arr B C G) (hfun_to_arr A B F)
                           hom (hf_to_ide A) (hf_to_ide C)"
          using assms hfun_to_arr_in_hom hf_to_ide_def
          by (metis (no_types, lifting) comp_in_homI mem_Collect_eq)
        moreover have "inj_on arr_to_hfun (hom (hf_to_ide A) (hf_to_ide C))"
        proof -
          have "ide (hf_to_ide A)  ide (hf_to_ide C)"
            using assms hf_to_ide_mapsto by auto
          thus ?thesis
            using bij_betw_hom_hfun [of "hf_to_ide A" "hf_to_ide C"] bij_betw_imp_inj_on
            by auto
        qed
        ultimately show ?thesis
          using 1 inj_on_def [of arr_to_hfun "hom (hf_to_ide A) (hf_to_ide C)"] by simp
      qed
    qed

    section "Binary Products"

    text‹
      The category of hereditarily finite sets has binary products,
      given by cartesian product of sets in the usual way.
    ›

    definition prod
    where "prod a b = hf_to_ide (ide_to_hf a * ide_to_hf b)"

    definition pr0
    where "pr0 a b = (if ide a  ide b then
                         mkArr (set (prod a b)) (set b) (λx. UP (hsnd (DOWN x)))
                      else null)"

    definition pr1
    where "pr1 a b = (if ide a  ide b then
                         mkArr (set (prod a b)) (set a) (λx. UP (hfst (DOWN x)))
                      else null)"

    definition tuple
    where "tuple f g = mkArr (set (dom f)) (set (prod (cod f) (cod g)))
                             (λx. UP (hpair (DOWN (Fun f x)) (DOWN (Fun g x))))"

    lemma ide_prod:
    assumes "ide a" and "ide b"
    shows "ide (prod a b)"
      using assms prod_def hf_to_ide_mapsto ide_to_hf_mapsto by auto

    lemma pr1_in_hom [intro]:
    assumes "ide a" and "ide b"
    shows "«pr1 a b : prod a b  a»"
    proof
      show 0: "arr (pr1 a b)"
      proof -
        have "set (prod a b)  Univ"
          using assms ide_prod ide_char set_subset_Univ by blast
        moreover have "set a  Univ"
          using assms ide_char set_subset_Univ by blast
        moreover have "(λx. UP (hfst (DOWN x)))  set (prod a b)  set a"
        proof (unfold prod_def)
          show "(λx. UP (hfst (DOWN x)))  set (hf_to_ide (ide_to_hf a * ide_to_hf b))  set a"
          proof
            fix x
              assume x: "x  set (hf_to_ide (ide_to_hf a * ide_to_hf b))"
              have "DOWN x  hfset (ide_to_hf a * ide_to_hf b)"
                using assms ide_char x
                by (metis (no_types, lifting) prod_def DOWN_membI HF_hfset UNIV_I hmem_HF_iff
                    ide_prod ide_to_hf_hf_to_ide)
              hence "hfst (DOWN x)  ide_to_hf a"
                by (metis HF_hfset finite_hfset hfst_conv hmem_HF_iff timesE)
              thus "UP (hfst (DOWN x))  set a"
                using UP_membI by simp
          qed
        qed
        ultimately show ?thesis
          unfolding pr1_def
          using assms arr_mkArr ide_prod set_card by presburger
      qed
      show "dom (pr1 a b) = prod a b"
        using assms 0 ide_char ide_prod dom_mkArr
        by (metis (no_types, lifting) mkIde_set pr1_def)
      show "cod (pr1 a b) = a"
        using assms 0 ide_char ide_prod cod_mkArr
        by (metis (no_types, lifting) mkIde_set pr1_def)
    qed

    lemma pr1_simps [simp]:
    assumes "ide a" and "ide b"
    shows "arr (pr1 a b)" and "dom (pr1 a b) = prod a b" and "cod (pr1 a b) = a"
      using assms pr1_in_hom by blast+

    lemma pr0_in_hom [intro]:
    assumes "ide a" and "ide b"
    shows "«pr0 a b : prod a b  b»"
    proof
      show 0: "arr (pr0 a b)"
      proof -
        have "set (prod a b)  Univ"
          using assms ide_prod ide_char set_subset_Univ by blast
        moreover have "set b  Univ"
          using assms ide_char set_subset_Univ by blast
        moreover have "(λx. UP (hsnd (DOWN x)))  set (prod a b)  set b"
        proof (unfold prod_def)
          show "(λx. UP (hsnd (DOWN x)))  set (hf_to_ide (ide_to_hf a * ide_to_hf b))  set b"
          proof
            fix x
              assume x: "x  set (hf_to_ide (ide_to_hf a * ide_to_hf b))"
              have "DOWN x  hfset (ide_to_hf a * ide_to_hf b)"
                using assms ide_char x
                by (metis (no_types, lifting) prod_def DOWN_membI HF_hfset UNIV_I hmem_HF_iff
                    ide_prod ide_to_hf_hf_to_ide)
              hence "hsnd (DOWN x)  ide_to_hf b"
                by (metis HF_hfset finite_hfset hsnd_conv hmem_HF_iff timesE)
              thus "UP (hsnd (DOWN x))  set b"
                using UP_membI by simp
          qed
        qed
        ultimately show ?thesis
          unfolding pr0_def
          using assms arr_mkArr ide_prod set_card by presburger
      qed
      show "dom (pr0 a b) = prod a b"
        using assms 0 ide_char ide_prod dom_mkArr
        by (metis (no_types, lifting) mkIde_set pr0_def)
      show "cod (pr0 a b) = b"
        using assms 0 ide_char ide_prod cod_mkArr
        by (metis (no_types, lifting) mkIde_set pr0_def)
    qed

    lemma pr0_simps [simp]:
    assumes "ide a" and "ide b"
    shows "arr (pr0 a b)" and "dom (pr0 a b) = prod a b" and "cod (pr0 a b) = b"
      using assms pr0_in_hom by blast+

    lemma UP_tuple_DOWN_membI:
    assumes "span f g" and "x  Dom f"
    shows "UP DOWN (Fun f x), DOWN (Fun g x)  set (prod (cod f) (cod g))"
    proof -
      have "Fun f x  set (cod f)"
        using assms Fun_mapsto by blast
      moreover have "Fun g x  set (cod g)"
        using assms Fun_mapsto by auto
      ultimately have "DOWN (Fun f x), DOWN (Fun g x)
                           ide_to_hf (cod f) * ide_to_hf (cod g)"
        using assms ide_cod by auto
      moreover have "set (prod (cod f) (cod g))  Univ"
        using assms ide_char ide_cod set_subset_Univ ide_prod by presburger
      ultimately show ?thesis
        using prod_def UP_membI ide_to_hf_hf_to_ide by auto
    qed

    lemma tuple_in_hom [intro]:
    assumes "span f g"
    shows "«tuple f g : dom f  prod (cod f) (cod g)»"
    proof
      show 1: "arr (tuple f g)"
      proof -
        have "Dom f  Univ"
          using assms set_subset_Univ ide_dom by blast
        moreover have "set (prod (cod f) (cod g))  Univ"
          using assms ide_char ide_cod set_subset_Univ ide_prod by presburger
        moreover have "(λx. UP DOWN (Fun f x), DOWN (Fun g x))
                           Dom f  set (prod (cod f) (cod g))"
          using assms UP_tuple_DOWN_membI by simp
        ultimately show ?thesis
          using assms ide_prod tuple_def arr_mkArr set_card ide_dom ide_cod by simp
      qed
      show "dom (tuple f g) = dom f"
        using assms 1 dom_mkArr ide_dom mkIde_set tuple_def by auto
      show "cod (tuple f g) = prod (cod f) (cod g)"
        using assms 1 cod_mkArr ide_cod mkIde_set tuple_def ide_prod by auto
    qed

    lemma tuple_simps [simp]:
    assumes "span f g"
    shows "arr (tuple f g)" and "dom (tuple f g) = dom f"
    and "cod (tuple f g) = prod (cod f) (cod g)"
      using assms tuple_in_hom by blast+

    lemma Fun_pr1:
    assumes "ide a" and "ide b"
    shows "Fun (pr1 a b) = restrict (λx. UP (hfst (DOWN x))) (set (prod a b))"
      using assms pr1_def Fun_mkArr arr_char pr1_simps(1) by presburger

    lemma Fun_pr0:
    assumes "ide a" and "ide b"
    shows "Fun (pr0 a b) = restrict (λx. UP (hsnd (DOWN x))) (set (prod a b))"
      using assms pr0_def Fun_mkArr arr_char pr0_simps(1) by presburger

    lemma Fun_tuple:
    assumes "span f g"
    shows "Fun (tuple f g) = restrict (λx. UP DOWN (Fun f x), DOWN (Fun g x)) (Dom f)"
    proof -
      have "arr (tuple f g)"
        using assms tuple_in_hom by blast
      thus ?thesis
        using assms tuple_def Fun_mkArr by simp
    qed

    lemma pr1_tuple:
    assumes "span f g"
    shows "comp (pr1 (cod f) (cod g)) (tuple f g) = f"
    proof (intro arr_eqI)
      have pr1: "«pr1 (cod f) (cod g) : prod (cod f) (cod g)  cod f»"
        using assms ide_cod by blast
      have tuple: "«tuple f g : dom f  prod (cod f) (cod g)»"
        using assms by blast
      show par: "par (comp (pr1 (cod f) (cod g)) (tuple f g)) f"
        using assms pr1_in_hom tuple_in_hom
        by (metis (no_types, lifting) comp_in_homI' ide_cod in_homE)
      show "Fun (comp (pr1 (cod f) (cod g)) (tuple f g)) = Fun f"
      proof -
        have seq: "seq (pr1 (cod f) (cod g)) (tuple f g)"
          using par by blast
        have "Fun (comp (pr1 (cod f) (cod g)) (tuple f g)) =
              restrict (Fun (pr1 (cod f) (cod g))  Fun (tuple f g)) (Dom (tuple f g))"
          using pr1 tuple seq Fun_comp by simp
        also have "... = restrict
                           (Fun (mkArr (set (prod (cod f) (cod g))) (Cod f)
                                       (λx. UP (hfst (DOWN x)))) 
                            Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
                                       (λx. UP DOWN (Fun f x), DOWN (Fun g x))))
                           (Dom (tuple f g))"
          unfolding pr1_def tuple_def
          using assms ide_cod by presburger
        also have
          "... = restrict
                   (restrict (λx. UP (hfst (DOWN x))) (set (prod (cod f) (cod g))) o
                      restrict (λx. UP DOWN (Fun f x), DOWN (Fun g x)) (Dom f))
                   (Dom f)"
        proof -
          have "Fun (mkArr (set (prod (cod f) (cod g))) (Cod f) (λx. UP (hfst (DOWN x)))) =
                restrict (λx. UP (hfst (DOWN x))) (set (prod (cod f) (cod g)))"
            using assms Fun_mkArr ide_prod pr1
            by (metis (no_types, lifting) arrI ide_cod pr1_def)
          moreover have "Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
                                    (λx. UP DOWN (Fun f x), DOWN (Fun g x))) =
                         restrict (λx. UP DOWN (Fun f x), DOWN (Fun g x)) (Dom f)"
            using assms Fun_mkArr ide_prod ide_cod tuple_def tuple arrI by simp
          ultimately show ?thesis
            using assms tuple_simps(2) by simp
        qed
        also have
          "... = restrict
                   ((λx. UP (hfst (DOWN x))) o (λx. UP DOWN (Fun f x), DOWN (Fun g x)))
                   (Dom f)"
          using assms tuple tuple_def UP_tuple_DOWN_membI by auto
        also have "... = restrict (Fun f) (Dom f)"
        proof
          fix x
          have "restrict ((λx. UP (hfst (DOWN x))) o (λx. UP DOWN (Fun f x), DOWN (Fun g x)))
                         (Dom f) x =
                restrict (λx. UP (DOWN (Fun f x))) (Dom f) x"
            by simp
          also have "... = restrict (Fun f) (Dom f) x"
          proof (cases "x  Dom f")
            show "x  Dom f  ?thesis" by simp
            assume x: "x  Dom f"
            have "Fun f x  Cod f"
              using assms x Fun_mapsto arr_char by blast
            moreover have "Cod f  Univ"
              using assms pr1 ide_cod set_subset_Univ by simp
            ultimately show ?thesis
              using assms UP_DOWN Fun_mapsto by auto
          qed
          finally show "restrict ((λx. UP (hfst (DOWN x))) 
                                    (λx. UP DOWN (Fun f x), DOWN (Fun g x)))
                                 (Dom f) x =
                        restrict (Fun f) (Dom f) x"
            by blast
        qed
        also have "... = Fun f"
          using assms par Fun_mapsto Fun_mkArr mkArr_Fun
          by (metis (no_types, lifting))
        finally show ?thesis by blast
      qed
    qed

    lemma pr0_tuple:
    assumes "span f g"
    shows "comp (pr0 (cod f) (cod g)) (tuple f g) = g"
    proof (intro arr_eqI)
      have pr0: "«pr0 (cod f) (cod g) : prod (cod f) (cod g)  cod g»"
        using assms ide_cod by blast
      have tuple: "«tuple f g : dom f  prod (cod f) (cod g)»"
        using assms by blast
      show par: "par (comp (pr0 (cod f) (cod g)) (tuple f g)) g"
        using assms pr0_in_hom tuple_in_hom
        by (metis (no_types, lifting) comp_in_homI' ide_cod in_homE)
      show "Fun (comp (pr0 (cod f) (cod g)) (tuple f g)) = Fun g"
      proof -
        have seq: "seq (pr0 (cod f) (cod g)) (tuple f g)"
          using par by blast
        have "Fun (comp (pr0 (cod f) (cod g)) (tuple f g)) =
              restrict (Fun (pr0 (cod f) (cod g))  Fun (tuple f g)) (Dom (tuple f g))"
          using pr0 tuple seq Fun_comp by simp
        also have
          "... = restrict
                   (Fun (mkArr (set (prod (cod f) (cod g))) (Cod g)
                               (λx. UP (hsnd (DOWN x)))) 
                    Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
                               (λx. UP DOWN (Fun f x), DOWN (Fun g x))))
                   (Dom (tuple f g))"
          unfolding pr0_def tuple_def
          using assms ide_cod by presburger
        also have "... = restrict
                           (restrict (λx. UP (hsnd (DOWN x))) (set (prod (cod f) (cod g))) o
                            restrict (λx. UP DOWN (Fun f x), DOWN (Fun g x)) (Dom g))
                           (Dom g)"
        proof -
          have "Fun (mkArr (set (prod (cod f) (cod g))) (Cod g) (λx. UP (hsnd (DOWN x)))) =
                restrict (λx. UP (hsnd (DOWN x))) (set (prod (cod f) (cod g)))"
            using assms Fun_mkArr ide_prod arrI
            by (metis (no_types, lifting) ide_cod pr0 pr0_def)
          moreover have "Fun (mkArr (Dom f) (set (prod (cod f) (cod g)))
                                    (λx. UP DOWN (Fun f x), DOWN (Fun g x))) =
                         restrict (λx. UP DOWN (Fun f x), DOWN (Fun g x)) (Dom f)"
            using assms Fun_mkArr ide_prod ide_cod tuple_def tuple arrI by simp
          ultimately show ?thesis
            using assms tuple_simps(2) by simp
        qed
        also have "... = restrict
                           ((λx. UP (hsnd (DOWN x))) o (λx. UP DOWN (Fun f x), DOWN (Fun g x)))
                           (Dom g)"
          using assms tuple tuple_def UP_tuple_DOWN_membI by auto
        also have "... = restrict (Fun g) (Dom g)"
        proof
          fix x
          have "restrict ((λx. UP (hsnd (DOWN x)))
                            o (λx. UP DOWN (Fun f x), DOWN (Fun g x)))
                         (Dom g) x =
                restrict (λx. UP (DOWN (Fun g x))) (Dom g) x"
            by simp
          also have "... = restrict (Fun g) (Dom g) x"
          proof (cases "x  Dom g")
            show "x  Dom g  ?thesis" by simp
            assume x: "x  Dom g"
            have "Fun g x  Cod g"
              using assms x Fun_mapsto arr_char by blast
            moreover have "Cod g  Univ"
              using assms pr0 ide_cod set_subset_Univ by simp
            ultimately show ?thesis
              using assms UP_DOWN Fun_mapsto by auto
          qed
          finally show "restrict ((λx. UP (hsnd (DOWN x))) 
                                    (λx. UP DOWN (Fun f x), DOWN (Fun g x)))
                                 (Dom g) x =
                        restrict (Fun g) (Dom g) x"
            by blast
        qed
        also have "... = Fun g"
          using assms par Fun_mapsto Fun_mkArr mkArr_Fun
          by (metis (no_types, lifting))
        finally show ?thesis by blast
      qed
    qed

    lemma tuple_pr:
    assumes "ide a" and "ide b" and "«h : dom h  prod a b»"
    shows "tuple (comp (pr1 a b) h) (comp (pr0 a b) h) = h"
    proof (intro arr_eqI)
      have pr0: "«pr0 a b : prod a b  b»"
        using assms pr0_in_hom ide_cod by blast
      have pr1: "«pr1 a b : prod a b  a»"
        using assms pr1_in_hom ide_cod by blast
      have tuple: "«tuple (comp (pr1 a b) h) (comp (pr0 a b) h) : dom h  prod a b»"
        using assms pr0 pr1
        by (metis (no_types, lifting) cod_comp dom_comp pr0_simps(3) pr1_simps(3)
            seqI' tuple_in_hom)
      show par: "par (tuple (comp (pr1 a b) h) (comp (pr0 a b) h)) h"
        using assms tuple by (metis (no_types, lifting) in_homE)
      show "Fun (tuple (comp (pr1 a b) h) (comp (pr0 a b) h)) = Fun h"
      proof -
        have 1: "Fun (comp (pr1 a b) h) =
                 restrict (restrict (λx. UP (hfst (DOWN x))) (set (prod a b))  Fun h) (Dom h)"
          using assms pr1 Fun_comp Fun_pr1 seqI' by auto
        have 2: "Fun (comp (pr0 a b) h) =
                 restrict (restrict (λx. UP (hsnd (DOWN x))) (set (prod a b))  Fun h) (Dom h)"
          using assms pr0 Fun_comp Fun_pr0 seqI' by auto
        have "Fun (tuple (comp (pr1 a b) h) (comp (pr0 a b) h)) =
              restrict (λx. UP DOWN (restrict
                                       (restrict (λx. UP (hfst (DOWN x))) (set (prod a b))  Fun h)
                                                 (Dom h) x),
                                DOWN (restrict
                                       (restrict (λx. UP (hsnd (DOWN x))) (set (prod a b))  Fun h)
                                                 (Dom h) x))
                       (Dom h)"
        proof -
          have "Dom (comp (pr1 a b) h) = Dom h"
            using assms pr1_in_hom
            by (metis (no_types, lifting) in_homE dom_comp seqI)
          moreover have "arr (mkArr (Dom (comp (pr1 a b) h))
                             (set (prod (cod (comp (pr1 a b) h)) (cod (comp (pr0 a b) h))))
                             (λx. UP DOWN (Fun (comp (pr1 a b) h) x),
                                      DOWN (Fun (comp (pr0 a b) h) x)))"
            using tuple unfolding tuple_def by blast
          ultimately show ?thesis
            using 1 2 tuple tuple_def
                  Fun_mkArr [of "Dom (comp (pr1 a b) h)"
                                 "set (prod (cod (comp (pr1 a b) h))
                                            (cod (comp (pr0 a b) h)))"
                                 "λx. UP DOWN (Fun (comp (pr1 a b) h) x),
                                          DOWN (Fun (comp (pr0 a b) h) x)"]
            by simp
        qed
        also have "... = Fun h"
        proof
          let ?f = "..."
          fix x
          show "?f x = Fun h x"
          proof -
            have "x  Dom h  ?f x = Fun h x"
            proof -
              assume x: "x  Dom h"
              have "restrict ?f (Dom h) x = undefined"
                using assms x restrict_apply by auto
              also have "... = Fun h x"
              proof -
                have "arr h"
                  using assms by blast
                thus ?thesis
                  using assms x Fun_mapsto [of h] extensional_arb [of "Fun h" "Dom h" x]
                  by simp
              qed
              finally show ?thesis by auto
            qed
            moreover have "x  Dom h  ?f x = Fun h x"
            proof -
              assume x: "x  Dom h"
              have 1: "Fun h x  set (prod a b)"
              proof -
                have "Fun h x  Cod h"
                  using assms x Fun_mapsto [of h] by blast
                moreover have "Cod h = set (prod a b)"
                  using assms ide_prod
                  by (metis (no_types, lifting) in_homE)
                ultimately show ?thesis by fast
              qed
              have "?f x = UP hfst (DOWN (Fun h x)), hsnd (DOWN (Fun h x))"
                using x 1 by simp
              also have "... = UP (DOWN (Fun h x))"
              proof -
                have "DOWN (Fun h x)  ide_to_hf a * ide_to_hf b"
                  using assms x 1 par
                  by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I ide_prod
                      ide_to_hf_hf_to_ide)
                thus ?thesis
                  using x is_hpair_def by auto
              qed
              also have "... = Fun h x"
                using assms 1 ide_prod set_subset_Univ UP_DOWN
                by (meson subsetD)
              finally show ?thesis by blast
            qed
            ultimately show ?thesis by blast
          qed
        qed
        finally show ?thesis by blast
      qed
    qed

    interpretation HF': elementary_category_with_binary_products comp pr0 pr1
    proof
      show "a b. ide a; ide b  span (pr1 a b) (pr0 a b)"
        using pr0_simps(1) pr0_simps(2) pr1_simps(1) pr1_simps(2) by auto
      show "a b. ide a; ide b  cod (pr0 a b) = b"
        using pr0_simps(1-3) by blast
      show "a b. ide a; ide b  cod (pr1 a b) = a"
        using pr1_simps(1-3) by blast
      show "f g. span f g 
                    ∃!l. comp (pr1 (cod f) (cod g)) l = f  comp (pr0 (cod f) (cod g)) l = g"
      proof
        fix f g
        assume fg: "span f g"
        show "comp (pr1 (cod f) (cod g)) (tuple f g) = f 
              comp (pr0 (cod f) (cod g)) (tuple f g) = g"
          using fg pr0_simps pr1_simps tuple_simps pr0_tuple pr1_tuple by presburger
        show "l. comp (pr1 (cod f) (cod g)) l = f  comp (pr0 (cod f) (cod g)) l = g
                       l = tuple f g "
        proof -
          fix l
          assume l: "comp (pr1 (cod f) (cod g)) l = f  comp (pr0 (cod f) (cod g)) l = g"
          show "l = tuple f g"
            using fg l tuple_pr
            by (metis (no_types, lifting) arr_iff_in_hom ide_cod seqE pr0_simps(2))
        qed
      qed
      show "a b. ¬ (ide a  ide b)  pr0 a b = null"
        using pr0_def by auto
      show "a b. ¬ (ide a  ide b)  pr1 a b = null"
        using pr1_def by auto
    qed

    text‹
      For reasons of economy of locale parameters, the notion prod› is a defined notion
      of the @{locale elementary_category_with_binary_products} locale.
      However, we need to be able to relate this notion to that of cartesian product of
      hereditarily finite sets, which we have already used to give a definition of prod›.
      The locale assumptions for @{locale elementary_cartesian_closed_category} refer
      specifically to HF'.prod›, even though in the end the notion itself does not depend
      on that choice.  To be able to show that the locale assumptions of
      @{locale elementary_cartesian_closed_category} are satisfied, we need to use a choice
      of products that we can relate to the cartesian product of hereditarily
      finite sets.  We therefore need to show that our previously defined prod› coincides
      (on objects) with the one defined in the @{locale elementary_category_with_binary_products} locale;
      \emph{i.e.}~HF'.prod›.  Note that the latter is defined for all arrows,
      not just identity arrows, so we need to use that for the subsequent definitions and proofs.
    ›

    lemma prod_ide_eq:
    assumes "ide a" and "ide b"
    shows "prod a b = HF'.prod a b"
      using assms prod_def HF'.pr_simps(2) HF'.prod_def pr0_simps(2) by presburger

    lemma tuple_span_eq:
    assumes "span f g"
    shows "tuple f g = HF'.tuple f g"
      using assms tuple_def HF'.tuple_def
      by (metis (no_types, lifting) HF'.tuple_eqI pr0_tuple pr1_tuple)

    section "Exponentials"

    text‹
      We now turn our attention to exponentials.
    ›

    definition exp
    where "exp b c = hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c))"

    definition eval
    where "eval b c = mkArr (set (HF'.prod (exp b c) b)) (set c)
                            (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))"

    definition Λ
    where "Λ a b c f = mkArr (set a) (set (exp b c))
                             (λx. UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                                 (arr_to_hfun f))
                                           (DOWN x)))"

    lemma ide_exp:
    assumes "ide b" and "ide c"
    shows "ide (exp b c)"
      using assms exp_def hf_to_ide_mapsto ide_to_hf_mapsto by auto

    lemma hfset_ide_to_hf:
    assumes "ide a"
    shows "hfset (ide_to_hf a) = DOWN ` set a"
      using assms ide_to_hf_def ide_implies_finite_set(1) by auto

    lemma eval_in_hom [intro]:
    assumes "ide b" and "ide c"
    shows "in_hom (eval b c) (HF'.prod (exp b c) b) c"
    proof
      show 1: "arr (eval b c)"
      proof (unfold eval_def arr_mkArr, intro conjI)
        show "set (HF'.prod (exp b c) b)  Univ"
          using assms ide_char HF'.ide_prod ide_exp set_subset_Univ by simp
        show "set c  Univ"
          using assms ide_char set_subset_Univ by simp
        show "(λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
                  set (HF'.prod (exp b c) b)  set c"
        proof
          fix x
          assume "x  set (HF'.prod (exp b c) b)"
          hence x: "x  set (prod (exp b c) b)"
            using assms prod_ide_eq ide_exp by auto
          show "UP (happ (hfst (DOWN x)) (hsnd (DOWN x)))  set c"
          proof (intro UP_membI)
            show "happ (hfst (DOWN x)) (hsnd (DOWN x))  ide_to_hf c"
            proof -
              have 1: "DOWN x  ide_to_hf (exp b c) * ide_to_hf b"
              proof -
                have "DOWN x  ide_to_hf (prod (exp b c) b)"
                  using assms x DOWN_membI ide_prod ide_exp by simp
                thus ?thesis
                  using assms x prod_def ide_to_hf_hf_to_ide by auto
              qed
              have "hfst (DOWN x)  hexp (ide_to_hf b) (ide_to_hf c)"
                using assms 1 x exp_def ide_to_hf_hf_to_ide by auto
              moreover have "hsnd (DOWN x)  ide_to_hf b"
                using assms 1 by auto
              ultimately show ?thesis
                using happ_mapsto [of "hfst (DOWN x)" "ide_to_hf b" "ide_to_hf c"
                                      "hsnd (DOWN x)"]
                by simp
            qed
          qed
        qed
        show "|set (HF'.prod (exp b c) b)| <o natLeq"
          using assms ide_exp HF'.ide_prod set_card by auto
        show "|set c| <o natLeq"
          using assms set_card by auto
      qed
      show "dom (eval b c) = HF'.prod (exp b c) b"
        using assms 1 ide_char HF'.ide_prod ide_exp dom_mkArr eval_def
        by (metis (no_types, lifting) mkIde_set)
      show "cod (eval b c) = c"
        using assms 1 ide_char cod_mkArr eval_def
        by (metis (no_types, lifting) mkIde_set)
    qed

    lemma eval_simps [simp]:
    assumes "ide b" and "ide c"
    shows "arr (eval b c)"
    and "dom (eval b c) = HF'.prod (exp b c) b"
    and "cod (eval b c) = c"
      using assms eval_in_hom by blast+

    lemma hlam_arr_to_hfun_in_hexp:
    assumes "ide a" and "ide b" and "ide c"
    and "in_hom f (prod a b) c"
    shows "hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f)
              hexp (ide_to_hf a) (ide_to_hf (exp b c))"
      using assms hfun_in_hexp hfun_hlam
      by (metis (no_types, lifting) prod_def HCollect_iff in_homE UNIV_I
          arr_to_hfun_in_hexp exp_def hexp_def ide_to_hf_hf_to_ide)

    lemma lam_in_hom [intro]:
    assumes "ide a" and "ide b" and "ide c"
    and "in_hom f (prod a b) c"
    shows "in_hom (Λ a b c f) a (exp b c)"
    proof
      show 1: "arr (Λ a b c f)"
      proof (unfold Λ_def arr_mkArr, intro conjI)
        show "set a  Univ"
          using assms(1) set_subset_Univ ide_char by blast
        show "set (exp b c)  Univ"
          using assms(2-3) set_subset_Univ ide_exp ide_char by simp
        show "|set a| <o natLeq"
          using assms(1) set_card by simp
        show "|set (exp b c)| <o natLeq"
          using assms(2-3) set_card ide_exp by auto
        show "(λx. UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
                            (DOWN x)))
                  set a  set (exp b c)"
        proof
          fix x
          assume x: "x  set a"
          show "UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
                         (DOWN x))
                      set (exp b c)"
            using assms x hlam_arr_to_hfun_in_hexp ide_to_hf_def DOWN_membI happ_mapsto
                  UP_membI
            by meson
        qed
      qed
      show "dom (Λ a b c f) = a"
        using assms(1) 1 Λ_def ide_char dom_mkArr mkIde_set by auto
      show "cod (Λ a b c f) = exp b c"
        using assms(2-3) 1 Λ_def cod_mkArr ide_exp mkIde_set by auto
    qed

    lemma lam_simps [simp]:
    assumes "ide a" and "ide b" and "ide c"
    and "in_hom f (prod a b) c"
    shows "arr (Λ a b c f)"
    and "dom (Λ a b c f) = a"
    and "cod (Λ a b c f) = exp b c"
      using assms lam_in_hom by blast+

    lemma Fun_lam:
    assumes "ide a" and "ide b" and "ide c"
    and "in_hom f (prod a b) c"
    shows "Fun (Λ a b c f) =
           restrict (λx. UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c) (arr_to_hfun f))
                                  (DOWN x)))
                    (set a)"
      using assms arr_char lam_simps(1) Λ_def Fun_mkArr by simp

    lemma Fun_eval:
    assumes "ide b" and "ide c"
    shows "Fun (eval b c) = restrict (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
                                     (set (HF'.prod (exp b c) b))"
      using assms arr_char eval_simps(1) eval_def Fun_mkArr by force

    lemma Fun_prod:
    assumes "arr f" and "arr g" and "x  set (prod (dom f) (dom g))"
    shows "Fun (HF'.prod f g) x = UP DOWN (Fun f (UP (hfst (DOWN x)))),
                                     DOWN (Fun g (UP (hsnd (DOWN x))))"
    proof -
      have 1: "span (comp f (pr1 (dom f) (dom g))) (comp g (pr0 (dom f) (dom g)))"
        using assms
        by (metis (no_types, lifting) HF'.prod_def HF'.prod_simps(1) HF'.tuple_ext not_arr_null)
      have 2: "Dom (comp f (pr1 (dom f) (dom g))) = set (prod (dom f) (dom g))"
        using assms
        by (metis (mono_tags, lifting) 1 dom_comp ide_dom pr0_simps(2))
      have 3: "Dom (comp g (pr0 (dom f) (dom g))) = set (prod (dom f) (dom g))"
        using assms 1 2 by force
      have "Fun (HF'.prod f g) x =
            Fun (HF'.tuple (comp f (pr1 (dom f) (dom g))) (comp g (pr0 (dom f) (dom g)))) x"
        using assms(3) HF'.prod_def by simp
      also have "... = restrict (λx. UP DOWN (Fun (comp f (pr1 (dom f) (dom g))) x),
                                         DOWN (Fun (comp g (pr0 (dom f) (dom g))) x))
                                (Dom (comp f (pr1 (dom f) (dom g))))
                                x"
        using assms 1 tuple_span_eq Fun_tuple by simp
      also have "... = UP DOWN (Fun (comp f (pr1 (dom f) (dom g))) x),
                           DOWN (Fun (comp g (pr0 (dom f) (dom g))) x)"
        using assms(3) 2 by simp
      also have "... = UP DOWN (Fun f (UP (hfst (DOWN x)))),
                           DOWN (Fun g (UP (hsnd (DOWN x))))"
      proof -
        have "Fun (comp f (pr1 (dom f) (dom g))) x = Fun f (UP (hfst (DOWN x)))"
        proof -
          (* TODO: Figure out what is making this proof so "stiff". *)
          have 4: "seq f (pr1 (dom f) (dom g))"
            using assms 1 by blast
          have "Fun (comp f (pr1 (dom f) (dom g))) x =
                restrict (Fun f  Fun (pr1 (dom f) (dom g))) (Dom (pr1 (dom f) (dom g))) x"
            using assms 1 Fun_comp [of f "pr1 (dom f) (dom g)"]
            by (metis (no_types, lifting))
          also have "... = (Fun f  Fun (pr1 (dom f) (dom g))) x"
          proof -
            have "x  Dom (pr1 (dom f) (dom g))"
              using assms 1 2 4
              by (metis (no_types, lifting) dom_comp)
            thus ?thesis by simp
          qed
          also have "... = Fun f (Fun (pr1 (dom f) (dom g)) x)"
            by simp
          also have "... = Fun f (UP (hfst (DOWN x)))"
            using assms 1 Fun_pr1 [of "dom f" "dom g"] ide_dom by simp
          finally show ?thesis by blast
        qed
        moreover
        have "Fun (comp g (pr0 (dom f) (dom g))) x = Fun g (UP (hsnd (DOWN x)))"
        proof -
          have 4: "seq g (pr0 (dom f) (dom g))"
            using assms 1 by blast
          have "Fun (comp g (pr0 (dom f) (dom g))) x =
                restrict (Fun g  Fun (pr0 (dom f) (dom g))) (Dom (pr0 (dom f) (dom g))) x"
            using assms 1 Fun_comp [of g "pr0 (dom f) (dom g)"]
            by (metis (no_types, lifting))
          also have "... = (Fun g  Fun (pr0 (dom f) (dom g))) x"
          proof -
            have "x  Dom (pr0 (dom f) (dom g))"
              using assms 1 2 4
              by (metis (no_types, lifting) dom_comp)
            thus ?thesis by simp
          qed
          also have "... = Fun g (Fun (pr0 (dom f) (dom g)) x)"
            by simp
          also have "... = Fun g (UP (hsnd (DOWN x)))"
            using assms 1 Fun_pr0 [of "dom f" "dom g"] ide_dom by simp
          finally show ?thesis by blast
        qed
        ultimately show ?thesis by simp
      qed
      finally show ?thesis by simp
    qed

    lemma prod_in_terms_of_tuple:
    assumes "arr f" and "arr g"
    shows "HF'.prod f g =
           tuple (comp f (pr1 (dom f) (dom g))) (comp g (pr0 (dom f) (dom g)))"
      using assms HF'.prod_def tuple_span_eq
      by (metis (no_types, lifting) HF'.prod_simps(1) HF'.tuple_ext not_arr_null)

    lemma eval_prod_lam:
    assumes "ide a" and "ide b" and "ide c"
    and "in_hom g (prod a b) c"
    shows "comp (eval b c) (HF'.prod (Λ a b c g) b) = g"
    proof -
      have ide_dom_lam: "ide (dom (Λ a b c g))"
        using assms lam_in_hom [of a b c g] ide_dom by blast
      have ide_dom_b: "ide (dom b)"
        using assms ide_dom ideD(1) by blast
      define Λ_pr1 where "Λ_pr1 = comp (Λ a b c g) (pr1 (dom (Λ a b c g)) (dom b))"
      define b_pr0 where "b_pr0 = comp b (pr0 (dom (Λ a b c g)) (dom b))"
      have lam_pr1: "in_hom Λ_pr1 (prod a b) (exp b c)"
      proof (unfold Λ_pr1_def, intro comp_in_homI)
        show "in_hom (pr1 (dom (Λ a b c g)) (dom b)) (prod a b) a"
          using assms ide_dom_lam ide_dom_b ideD(2) lam_simps(2) pr1_in_hom by auto
        show "in_hom (Λ a b c g) a (exp b c)"
          using assms lam_in_hom by simp
      qed
      have b_pr0: "in_hom b_pr0 (prod a b) b"
        using assms b_pr0_def
        by (metis (no_types, lifting) HF'.arr_pr0_iff HF'.cod_pr0 comp_in_homI'
            ideD(1-3) lam_simps(2) pr0_simps(2))
      have 1: "span Λ_pr1 b_pr0"
        using lam_pr1 b_pr0
        by (metis (no_types, lifting) in_homE)
      have tuple: "in_hom (tuple Λ_pr1 b_pr0) (prod a b) (prod (exp b c) b)"
        using 1 lam_pr1 b_pr0 tuple_in_hom [of Λ_pr1 b_pr0]
        by (metis (mono_tags, lifting) in_homE)
      define Λ_pr1' where "Λ_pr1' = comp (Λ a b c g) (pr1 a b)"
      define b_pr0' where "b_pr0' = pr0 a b"
      have lam_pr1_eq: "Λ_pr1 = Λ_pr1'"
        using assms Λ_pr1_def Λ_pr1'_def ideD(2) lam_simps(2) by auto
      have b_pr0_eq: "b_pr0 = b_pr0'"
        using assms b_pr0_def b_pr0'_def b_pr0 comp_ide_arr
        by (metis (no_types, lifting) ideD(2) in_homE lam_simps(2))
      have Fun_pr0: "Fun (pr0 a b) = restrict (λx. UP (hsnd (DOWN x))) (set (prod a b))"
        using assms Fun_pr0 by simp
      have Fun_lam_pr1: "Fun Λ_pr1 =
                         restrict (Fun (Λ a b c g) o
                                   restrict (λx. UP (hfst (DOWN x))) (set (prod a b)))
                                  (set (prod a b))"
        using assms 1 Fun_comp Fun_pr1 lam_pr1_eq Λ_pr1'_def
        by (metis (no_types, lifting) pr1_simps(2))
      have "comp (eval b c) (HF'.prod (Λ a b c g) b) = comp (eval b c) (tuple Λ_pr1 b_pr0)"
        using assms Λ_pr1_def b_pr0_def 1 prod_in_terms_of_tuple ideD(1) lam_simps(1)
        by presburger
      also have 5: "... = comp (eval b c) (tuple Λ_pr1' b_pr0')"
        using lam_pr1_eq b_pr0_eq by simp
      also have "... = g"
      proof (intro arr_eqI)
        have 2: "arr (comp (eval b c) (tuple Λ_pr1 b_pr0))"
          using assms tuple arr_char
          by (metis (no_types, lifting) in_homE seqI eval_simps(1-2) ide_exp prod_ide_eq)
        have 3: "arr g"
          using assms by blast
        have tuple': "in_hom (tuple Λ_pr1' b_pr0') (prod a b) (prod (exp b c) b)"
          using tuple lam_pr1_eq b_pr0_eq by blast
        have 4: "Dom g = set (prod a b)"
          using assms
          by (metis (no_types, lifting) in_homE)
        show par: "par (comp (eval b c) (tuple Λ_pr1' b_pr0')) g"
          using assms tuple' 2 3 5
          by (metis (no_types, lifting) cod_comp dom_comp in_homE eval_simps(3))
        show "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) = Fun g"
        proof
          fix x
          have "x  set (prod a b)  Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x = Fun g x"
          proof -
            have 5: "Fun g  extensional (Dom g)"
              using assms 3 Fun_mapsto by simp
            moreover have "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0'))  extensional (Dom g)"
              using 5 par Fun_mapsto by (metis (no_types, lifting) Int_iff)
            ultimately show "x  set (prod a b) 
                             Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x = Fun g x"
              using 4 extensional_arb [of "Fun g" "Dom g" x]
                    extensional_arb [of "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0'))" "Dom g" x]
              by force
          qed
          moreover have "x  set (prod a b) 
                           Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x = Fun g x"
          proof -
            assume x: "x  set (prod a b)"
            have 6: "Dom (tuple Λ_pr1' b_pr0') = set (prod a b)"
              using assms 4 tuple' par
              by (metis (no_types, lifting) in_homE)
            have "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x =
                  Fun (eval b c) (Fun (tuple Λ_pr1' b_pr0') x)"
            proof -
              have "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x =
                    (Fun (eval b c)  Fun (tuple Λ_pr1' b_pr0')) x"
                using assms par x 6 Fun_comp [of "eval b c" "tuple Λ_pr1' b_pr0'"] by auto
              also have "... = Fun (eval b c) (Fun (tuple Λ_pr1' b_pr0') x)"
                by simp
              finally show ?thesis by blast
            qed
            also have "... = restrict (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
                                      (set (HF'.prod (exp b c) b))
                                      (Fun (tuple Λ_pr1' b_pr0') x)"
              using assms Fun_eval by simp
            also have "... = (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
                               (Fun (tuple Λ_pr1' b_pr0') x)"
            proof -
              have "Fun (tuple Λ_pr1' b_pr0') x  set (HF'.prod (exp b c) b)"
              proof -
                have "x  Dom (tuple Λ_pr1' b_pr0')"
                  using x 6 by blast
                moreover have "Cod (tuple Λ_pr1' b_pr0') = set (HF'.prod (exp b c) b)"
                  by (metis (no_types, lifting) in_homE assms(2-3) ide_exp
                      prod_ide_eq tuple')
                moreover have "arr (tuple Λ_pr1' b_pr0')"
                  using tuple' by blast
                ultimately show ?thesis
                  using tuple' Fun_mapsto [of "tuple Λ_pr1' b_pr0'"] by auto
              qed
              thus ?thesis
                using restrict_apply by simp
            qed
            also have "... = (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
                               (UP DOWN (Fun Λ_pr1' x), DOWN (Fun b_pr0' x))"
            proof -
              have 7: "Dom Λ_pr1' = set (prod a b)"
                using assms
                by (metis (no_types, lifting) 1 comp_ide_arr ideD(2)
                    b_pr0_def lam_pr1_eq lam_simps(2) pr0_simps(2))
              moreover have "span Λ_pr1' b_pr0'"
                using assms 1 b_pr0_eq lam_pr1_eq by auto
              moreover have "x  Dom Λ_pr1'"
                using x 7 by simp
              ultimately have "Fun (tuple Λ_pr1' b_pr0') x =
                               UP DOWN (Fun Λ_pr1' x), DOWN (Fun b_pr0' x)"
                using assms x restrict_apply Fun_tuple by simp
              thus ?thesis by simp
            qed
            also have "... = UP (happ (DOWN (Fun Λ_pr1' x)) (DOWN (Fun b_pr0' x)))"
              using assms by simp
            also have "... = UP (happ (DOWN (UP (happ (hlam (ide_to_hf a) (ide_to_hf b)
                                                            (ide_to_hf c) (arr_to_hfun g))
                                      (hfst (DOWN x)))))
                                      (DOWN (UP (hsnd (DOWN x)))))"
            proof -
              have "Fun b_pr0' x = UP (hsnd (DOWN x))"
                using assms x Fun_pr0 b_pr0'_def by simp
              moreover have "Fun Λ_pr1' x =
                             UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                            (arr_to_hfun g))
                                      (hfst (DOWN x)))"
              proof -
                have "Fun Λ_pr1' x =
                      restrict (Fun (Λ a b c g) o Fun (pr1 a b)) (Dom (pr1 a b)) x"
                  using assms x Fun_pr1 Fun_comp lam_pr1_eq Fun_lam_pr1 pr1_simps(1-2)
                  by presburger
                also have "... = Fun (Λ a b c g) (Fun (pr1 a b) x)"
                  using assms x restrict_apply Fun_lam_pr1 Fun_pr1 calculation lam_pr1_eq
                  by auto
                also have "... = restrict (λx. UP (happ (hlam (ide_to_hf a) (ide_to_hf b)
                                                              (ide_to_hf c) (arr_to_hfun g))
                                          (DOWN x)))
                                          (set a)
                                          (Fun (pr1 a b) x)"
                  using assms x Fun_lam by simp
                also have "... = UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                                (arr_to_hfun g))
                                          (DOWN (Fun (pr1 a b) x)))"
                proof -
                  have "Fun (pr1 a b) x  set a"
                  proof -
                    have "x  Dom (pr1 a b)"
                      using assms x pr1_simps(1-2) by auto
                    moreover have "Cod (pr1 a b) = set a"
                      using assms HF'.cod_pr1 pr1_simps(1) by auto
                    moreover have "arr (pr1 a b)"
                      using assms arr_char by blast
                    ultimately show ?thesis
                      using Fun_mapsto [of "pr1 a b"] by auto
                  qed
                  thus ?thesis
                    using restrict_apply by simp
                qed
                also have "... = UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                                (arr_to_hfun g))
                                          (hfst (DOWN x)))"
                  using assms x Fun_pr1 Fun_lam [of a b c g] by simp
                finally show ?thesis by simp
              qed
              ultimately show ?thesis by simp
            qed
            also have "... = UP (happ (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                                  (arr_to_hfun g))
                                            (hfst (DOWN x)))
                                      (hsnd (DOWN x)))"
              by simp
            also have "... = UP (happ (arr_to_hfun g) (DOWN x))"
              using assms x happ_hlam
              by (metis (no_types, lifting) prod_def DOWN_membI HCollect_iff ide_dom
                  in_homE UNIV_I arr_to_hfun_in_hexp hexp_def hfst_conv hsnd_conv
                  ide_to_hf_hf_to_ide timesE)
            also have "... = Fun g x"
              using assms x 3 4 Fun_char [of g] restrict_apply [of "Fun g" "Dom g" x]
              by simp
            finally show ?thesis by simp
          qed
          ultimately show "Fun (comp (eval b c) (tuple Λ_pr1' b_pr0')) x = Fun g x"
            by auto
        qed
      qed
      finally show ?thesis by simp
    qed

    lemma lam_eval_prod:
    assumes "ide a" and "ide b" and "ide c"
    and "in_hom h a (exp b c)"
    shows a b c (comp (eval b c) (HF'.prod h b)) = h"
    proof (intro arr_eqI)
      have 0: "in_hom (comp (eval b c) (HF'.prod h b)) (prod a b) c"
      proof
        show "in_hom (HF'.prod h b) (prod a b) (HF'.prod (exp b c) b)"
        proof
          show 1: "arr (HF'.prod h b)"
            using assms HF'.prod_in_hom'
            by (metis (no_types, lifting) ideD(1) in_homE)
          show "dom (HF'.prod h b) = prod a b"
            using assms 1
            by (metis (no_types, lifting) HF'.prod_simps(2) ideD(1-2) in_homE prod_ide_eq)
          show "cod (HF'.prod h b) = HF'.prod (exp b c) b"
            using assms 1
            by (metis (no_types, lifting) HF'.prod_simps(3) ideD(1,3) in_homE)
        qed
        show "in_hom (eval b c) (HF'.prod (exp b c) b) c"
          using assms by blast
      qed
      have 1: "in_hom (Λ a b c (comp (eval b c) (HF'.prod h b))) a (exp b c)"
        using assms 0 by blast
      have 2: "Fun (comp (eval b c) (HF'.prod h b)) =
               restrict (Fun (eval b c)  Fun (HF'.prod h b))
                        (set (HF'.prod a b))"
      proof -
        have "seq (eval b c) (HF'.prod h b)"
          using assms 1
          by (metis (no_types, lifting) 0 in_homE)
        moreover have "Dom (HF'.prod h b) = set (HF'.prod a b)"
          using assms
          by (metis (no_types, lifting) HF'.prod_simps(2) ideD(1-2) in_homE)
        ultimately show ?thesis
          using assms Fun_comp [of "eval b c" "HF'.prod h b"] by simp
      qed
      show par: "par (Λ a b c (comp (eval b c) (HF'.prod h b))) h"
        using assms 1
        by (metis (no_types, lifting) in_homE)
      show "Fun (Λ a b c (comp (eval b c) (HF'.prod h b))) = Fun h"
      proof
        fix x
        show "Fun (Λ a b c (comp (eval b c) (HF'.prod h b))) x = Fun h x"
        proof -
          have "x  set a  ?thesis"
            using assms 1 Fun_mapsto
                  extensional_arb [of "Fun h" "set a" x]
                  extensional_arb [of "Fun (Λ a b c (comp (eval b c) (HF'.prod h b)))"
                                      "set a" x]
            by (metis (no_types, lifting) 0 Int_iff lam_simps(2) par)
          moreover have "x  set a  ?thesis"
          proof -
            assume x: "x  set a"
            have 3: "dom (comp (eval b c) (HF'.prod h b)) = HF'.prod a b"
              using assms 0 in_homE prod_ide_eq by auto
            have 4: "cod (comp (eval b c) (HF'.prod h b)) = c"
              using assms 0 by blast
            have 5: "dom (comp (eval b c) (HF'.prod h b)) = HF'.prod a b"
              using assms 3
              by (metis (mono_tags, lifting))
            have 6: "cod (comp (eval b c) (HF'.prod h b)) = c"
              using assms 4 by (metis (no_types, lifting))
            have "arr_to_hfun (comp (eval b c) (HF'.prod h b)) =
                  xy  ide_to_hf (HF'.prod a b) * ide_to_hf c.
                     hsnd xy = DOWN (Fun (comp (eval b c) (HF'.prod h b)) (UP (hfst xy)))"
              unfolding arr_to_hfun_def
              using 2 5 6 by metis
            have "Fun (Λ a b c (comp (eval b c) (HF'.prod h b))) x =
                  UP (happ (hlam (ide_to_hf a) (ide_to_hf b) (ide_to_hf c)
                                 (arr_to_hfun (comp (eval b c) (HF'.prod h b))))
                           (DOWN x))"
              using assms 0 x Fun_lam by auto
            also have "... = UP yz  ide_to_hf b * ide_to_hf c.
                                   DOWN x, hfst yz, hsnd yz
                                       arr_to_hfun (comp (eval b c) (HF'.prod h b))"
            proof -
              have "seq (eval b c) (HF'.prod h b)"
                using assms 0 by blast
              moreover have "ide_to_hf (dom (comp (eval b c) (HF'.prod h b))) =
                             ide_to_hf a * ide_to_hf b"
                using assms 1 3
                by (metis (no_types, lifting) prod_def UNIV_I ide_to_hf_hf_to_ide prod_ide_eq)
              moreover have "ide_to_hf (cod (comp (eval b c) (HF'.prod h b))) = ide_to_hf c"
                using assms 2 4 by auto
              ultimately show ?thesis
                using assms 0 x happ_hlam(3) DOWN_membI
                      hfun_arr_to_hfun [of "comp (eval b c) (HF'.prod h b)"]
                by simp
            qed
            also have "... = UP yz  ide_to_hf b * ide_to_hf c.
                                   hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
                                                       (UP DOWN x, hfst yz))"
            proof -
              have "yz  ide_to_hf b * ide_to_hf c.
                       DOWN x, hfst yz, hsnd yz
                           arr_to_hfun (comp (eval b c) (HF'.prod h b)) =
                    yz  ide_to_hf b * ide_to_hf c.
                                   hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
                                                       (UP DOWN x, hfst yz))"
              proof
                fix yz
                show "yz  yz  ide_to_hf b * ide_to_hf c.
                                   DOWN x, hfst yz, hsnd yz
                                       arr_to_hfun (comp (eval b c) (HF'.prod h b)) 
                      yz  yz  ide_to_hf b * ide_to_hf c.
                                   hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
                                                     (UP DOWN x, hfst yz))"
                proof -
                  have "yz  ide_to_hf b * ide_to_hf c 
                        DOWN x, hfst yz, hsnd yz  arr_to_hfun (comp (eval b c) (HF'.prod h b))
                           hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
                                                     (UP DOWN x, hfst yz))"
                  proof -
                    assume yz: "yz  ide_to_hf b * ide_to_hf c"
                    have "DOWN x, hfst yz, hsnd yz
                              arr_to_hfun (comp (eval b c) (HF'.prod h b))
                            
                          DOWN x, hfst yz, hsnd yz  ide_to_hf (HF'.prod a b) * ide_to_hf c 
                          hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
                                         (UP DOWN x, hfst yz))"
                      unfolding arr_to_hfun_def
                      using assms 5 6
                      by (metis (mono_tags, lifting) HCollect_iff hfst_conv hsnd_conv)
                      (* 20 sec *)
                    moreover have "DOWN x, hfst yz, hsnd yz
                                       ide_to_hf (prod a b) * ide_to_hf c"
                    proof -
                      have "DOWN x, hfst yz  ide_to_hf (HF'.prod a b)"
                        using assms x yz
                        by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I hfst_conv
                            ide_to_hf_hf_to_ide prod_ide_eq timesE times_iff)
                      thus ?thesis
                        using yz assms(1-2) prod_ide_eq by auto
                    qed
                    ultimately show ?thesis
                      using assms(1-2) prod_ide_eq by auto
                  qed
                  thus ?thesis by auto
                qed
              qed
              thus ?thesis by simp
            qed
            also have "... = UP yz  ide_to_hf b * ide_to_hf c. yz  DOWN (Fun h x)"
            proof -
              have "yz  ide_to_hf b * ide_to_hf c.
                       hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
                                               (UP DOWN x, hfst yz)) =
                    yz  ide_to_hf b * ide_to_hf c. yz  DOWN (Fun h x)"
              proof -
                have "yz. yz  ide_to_hf b * ide_to_hf c 
                             hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
                                            (UP DOWN x, hfst yz))
                               
                             yz  DOWN (Fun h x)"
                proof -
                  fix yz
                  assume yz: "yz  ide_to_hf b * ide_to_hf c"
                  have 7: "UP DOWN x, hfst yz  set (HF'.prod a b)"
                    using assms x yz UP_membI
                    by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I hfst_conv
                        ide_to_hf_hf_to_ide prod_ide_eq timesE times_iff)
                  have 8: "Fun h x  set (exp b c)"
                  proof -
                    have "Fun h x  Cod h"
                      using assms x Fun_mapsto by blast
                    moreover have "Cod h = set (exp b c)"
                      using assms 0 lam_simps(3) par by auto
                    ultimately show ?thesis by blast
                  qed
                  show "hsnd yz = DOWN (Fun (comp (eval b c) (HF'.prod h b))
                                            (UP DOWN x, hfst yz))
                           
                        yz  DOWN (Fun h x)"
                  proof -
                    have "Fun (comp (eval b c) (HF'.prod h b)) (UP DOWN x, hfst yz) =
                            UP (happ (DOWN (Fun h x)) (hfst yz))"
                    proof -
                      have "Fun (comp (eval b c) (HF'.prod h b)) (UP DOWN x, hfst yz) =
                            restrict (Fun (eval b c)  Fun (HF'.prod h b))
                                     (set (HF'.prod a b))
                                     (UP DOWN x, hfst yz)"
                        using assms x yz 2 by simp
                      also have "... = Fun (eval b c)
                                               (Fun (HF'.prod h b) (UP DOWN x, hfst yz))"
                        using 7 by simp
                      also have "... = Fun (eval b c)
                                               (UP DOWN (Fun h x),
                                                    DOWN (Fun b (UP (hfst yz))))"
                      proof -
                        have "Fun (HF'.prod h b) (UP DOWN x, hfst yz) =
                           UP DOWN (Fun h x), DOWN (Fun b (UP (hfst yz)))"
                        proof -
                          have "Fun (HF'.prod h b) (UP DOWN x, hfst yz) =
                                UP DOWN (Fun h (UP (hfst (DOWN (UP DOWN x, hfst yz))))),
                                    DOWN (Fun b (UP (hsnd (DOWN (UP DOWN x, hfst yz)))))"
                          proof -
                            have "UP DOWN x, hfst yz  set (prod (dom h) (dom b))"
                              using assms x yz 7
                              by (metis (no_types, lifting) ideD(2) in_homE prod_ide_eq)
                            thus ?thesis
                              using assms x yz Fun_prod ideD(1) by blast
                          qed
                          also have "... = UP DOWN (Fun h (UP (DOWN x))),
                                               DOWN (Fun b (UP (hfst yz)))"
                            using assms x yz by simp
                          also have "... = UP DOWN (Fun h x), DOWN (Fun b (UP (hfst yz)))"
                            using assms(1) set_subset_Univ x by force
                          finally show ?thesis by simp
                        qed
                        thus ?thesis by simp
                      qed
                      also have "... = Fun (eval b c) (UP DOWN (Fun h x), hfst yz)"
                        using assms x yz Fun_ide ide_char UP_membI by auto
                      also have "... = restrict (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
                                                (set (HF'.prod (exp b c) b))
                                                (UP DOWN (Fun h x), hfst yz)"
                        using assms Fun_eval [of b c] by simp
                      also have "... = (λx. UP (happ (hfst (DOWN x)) (hsnd (DOWN x))))
                                         (UP DOWN (Fun h x), hfst yz)"
                      proof -
                        have "UP DOWN (Fun h x), hfst yz
                                  set (HF'.prod (exp b c) b)"
                        proof -
                          have 1: "ide_to_hf (HF'.prod (exp b c) b) =
                                   HF (DOWN ` set (HF'.prod (exp b c) b))"
                            unfolding ide_to_hf_def by blast
                          have "DOWN (Fun h x), hfst yz
                                   HF (DOWN ` set (HF'.prod (exp b c) b))"
                            using assms x yz 1 8 Fun_mapsto [of h]
                            by (metis (no_types, lifting) prod_def DOWN_membI UNIV_I
                                hfst_conv ide_exp ide_to_hf_hf_to_ide prod_ide_eq timesE times_iff)
                          thus ?thesis
                            using assms x yz 1 UP_membI [of "DOWN (Fun h x), hfst yz"]
                            by auto
                        qed
                        thus ?thesis by simp
                      qed
                      also have "... = UP (happ (DOWN (Fun h x)) (hfst yz))"
                        by simp
                      finally show ?thesis by simp
                    qed
                    hence 9: "DOWN (Fun (comp (eval b c) (HF'.prod h b))
                                        (UP DOWN x, hfst yz)) =
                              happ (DOWN (Fun h x)) (hfst yz)"
                      by simp
                    show ?thesis
                    proof -
                      have "hsnd yz = happ (DOWN (Fun h x)) (hfst yz)
                               yz  DOWN (Fun h x)"
                      proof
                        have 10: "∃!z. hfst yz, z  DOWN (Fun h x)"
                        proof -
                          have "hfun (ide_to_hf b) (ide_to_hf c) (DOWN (Fun h x))"
                            using assms x 8
                            by (metis (no_types, lifting) DOWN_membI HCollect_iff UNIV_I
                                exp_def hexp_def ide_exp ide_to_hf_hf_to_ide)
                          thus ?thesis
                            using assms yz
                                  hfunE [of "ide_to_hf b" "ide_to_hf c" "DOWN (Fun h x)"]
                            by (metis (no_types, lifting) hfst_conv timesE)
                        qed
                        show "yz  DOWN (Fun h x)
                                 hsnd yz = happ (DOWN (Fun h x)) (hfst yz)"
                        proof -
                          assume yz1: "yz  DOWN (Fun h x)"
                          show "hsnd yz = happ (DOWN (Fun h x)) (hfst yz)"
                            unfolding app_def
                            using assms x yz yz1 10 hfun_arr_to_hfun arr_to_hfun_def
                                  the1_equality
                                    [of "λy. hfst yz, y  DOWN (Fun h x)" "hsnd yz"]
                            by (metis (no_types, lifting) hfst_conv hsnd_conv timesE)
                        qed
                        show "hsnd yz = happ (DOWN (Fun h x)) (hfst yz)
                                 yz  DOWN (Fun h x)"
                          unfolding app_def
                          using assms x yz 10
                                theI' [of "λy. hfst yz, y  DOWN (Fun h x)"]
                          by (metis (no_types, lifting) hfst_conv hsnd_conv timesE)
                      qed
                      thus ?thesis
                        using 9 by simp
                    qed
                  qed
                qed
                thus ?thesis by blast
              qed
              thus ?thesis by simp
            qed
            also have "... = Fun h x"
            proof -
              have H: "Fun h x = restrict (λx. UP (happ (arr_to_hfun h) (DOWN x))) (Dom h) x"
              proof -
                have "arr h"
                  using assms by blast
                thus ?thesis
                  using assms x Fun_char by simp
              qed
              also have "... = UP (happ (arr_to_hfun h) (DOWN x))"
                using assms x par
                by (metis (no_types, lifting) 0 lam_simps(2) restrict_apply)
              also have "... = UP (THE g. DOWN x, g  arr_to_hfun h)"
                using app_def by simp
              also have "... = UP yz  ide_to_hf b * ide_to_hf c. yz  DOWN (Fun h x)"
              proof -
                have ex_un_g: "∃!g. DOWN x, g  arr_to_hfun h"
                  using assms x arr_to_hfun_def hfun_arr_to_hfun
                        hfunE [of "ide_to_hf a" "ide_to_hf (exp b c)" "arr_to_hfun h"]
                  by (metis (no_types, lifting) DOWN_membI in_homE)
                moreover have
                   "DOWN x, yz  ide_to_hf b * ide_to_hf c. yz  DOWN (Fun h x)
                        arr_to_hfun h"
                proof -
                  have "DOWN (Fun h x) =
                        yz  ide_to_hf b * ide_to_hf c. yz  DOWN (Fun h x)"
                  proof
                    fix yz
                    show "yz  DOWN (Fun h x) 
                          yz  yz  ide_to_hf b * ide_to_hf c. yz  DOWN (Fun h x)"
                    proof
                      show "yz  DOWN (Fun h x)
                               yz  yz  ide_to_hf b * ide_to_hf c. yz  DOWN (Fun h x)"
                      proof -
                        assume yz: "yz  DOWN (Fun h x)"
                        have "yz  ide_to_hf b * ide_to_hf c"
                        proof -
                          have "DOWN (Fun h x)  hexp (ide_to_hf b) (ide_to_hf c)"
                          proof -
                            have "ide (hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c)))"
                              using assms exp_def ide_exp by auto
                            moreover have
                              "Fun h x  set (hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c)))"
                            proof -
                              have "Fun h x  Cod h"
                                using assms x Fun_mapsto by blast
                              moreover have
                                "Cod h = set (hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c)))"
                                using assms 0 exp_def lam_simps(3) par by auto
                              ultimately show ?thesis by blast
                            qed
                            ultimately show ?thesis
                              using DOWN_membI [of "hf_to_ide (hexp (ide_to_hf b) (ide_to_hf c))"
                                                   "Fun h x"]
                              by (simp add: ide_to_hf_hf_to_ide)
                          qed
                          thus ?thesis
                            using assms yz hexp_def by auto
                        qed
                        thus ?thesis
                          using assms x yz by blast
                      qed
                      show "yz  yz  ide_to_hf b * ide_to_hf c. yz  DOWN (Fun h x)
                               yz  DOWN (Fun h x)"
                        using assms by simp
                    qed
                  qed
                  moreover have "UP (DOWN x) = x"
                    using assms x ide_char set_subset_Univ UP_DOWN
                    by (meson subsetD)
                  ultimately show ?thesis
                    using assms x arr_to_hfun_def ex_un_g by auto
                qed
                ultimately show ?thesis
                  using assms x theI' [of "λg. DOWN x, g  arr_to_hfun h"]
                  by fastforce
              qed
              finally show ?thesis
                using assms x by simp
            qed
            finally show ?thesis by simp
          qed
          ultimately show "Fun (Λ a b c (comp (eval b c) (HF'.prod h b))) x = Fun h x"
            by blast
        qed
      qed
    qed

    section "The Main Results"

    interpretation cartesian_closed_category comp
    proof -
      interpret elementary_cartesian_closed_category comp pr0 pr1
                       some_terminal trm exp eval Λ
        using ide_exp eval_in_hom lam_in_hom prod_ide_eq eval_prod_lam lam_eval_prod
        by unfold_locales auto
      show "cartesian_closed_category comp"
        using is_cartesian_closed_category by simp
    qed

    theorem is_cartesian_closed_category:
    shows "cartesian_closed_category comp"
      ..

    theorem is_category_with_finite_limits:
    shows "category_with_finite_limits comp"
    proof
      fix J :: "'j comp"
      assume J: "category J"
      interpret J: category J
        using J by simp
      assume finite: "finite (Collect J.arr)"
      have "has_products (Collect J.ide)"
      proof -
        have "Collect J.ide  UNIV"
          using J.not_arr_null by blast
        moreover have "finite (Collect J.ide)"
        proof -
          have "Collect J.ide  Collect J.arr"
            by auto
          thus ?thesis
            using finite J.ideD(1) finite_subset by blast
        qed
        ultimately show ?thesis
          using finite has_finite_products' by simp
      qed
      moreover have "has_products (Collect J.arr)"
      proof -
        have "Collect J.arr  UNIV"
          using J.not_arr_null by blast
        thus ?thesis
          using finite has_finite_products' by simp
      qed
      ultimately show "has_limits_of_shape J"
        using J.category_axioms has_limits_if_has_products [of J] by simp
    qed

  end

end